summaryrefslogtreecommitdiff
path: root/compiler/deSugar/DsBinds.lhs
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2014-09-26 12:58:41 +0100
committerSimon Peyton Jones <simonpj@microsoft.com>2014-09-26 13:55:11 +0100
commit0ef1cc67dc472493b7dee1a28dedbfe938536b8f (patch)
tree59aa09b676707607792fd8a0430ba23afc608839 /compiler/deSugar/DsBinds.lhs
parentac157de3cd959a18a71fa056403675e2c0563497 (diff)
downloadhaskell-0ef1cc67dc472493b7dee1a28dedbfe938536b8f.tar.gz
De-tabify and remove trailing whitespace
Diffstat (limited to 'compiler/deSugar/DsBinds.lhs')
-rw-r--r--compiler/deSugar/DsBinds.lhs348
1 files changed, 171 insertions, 177 deletions
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 37c16325e0..a8d37a4bdd 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -11,12 +11,6 @@ lower levels it is preserved with @let@/@letrec@s).
\begin{code}
{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
dsHsWrapper, dsTcEvBinds, dsEvBinds
@@ -24,15 +18,15 @@ module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
#include "HsVersions.h"
-import {-# SOURCE #-} DsExpr( dsLExpr )
-import {-# SOURCE #-} Match( matchWrapper )
+import {-# SOURCE #-} DsExpr( dsLExpr )
+import {-# SOURCE #-} Match( matchWrapper )
import DsMonad
import DsGRHSs
import DsUtils
-import HsSyn -- lots of things
-import CoreSyn -- lots of things
+import HsSyn -- lots of things
+import CoreSyn -- lots of things
import Literal ( Literal(MachStr) )
import CoreSubst
import OccurAnal ( occurAnalyseExpr )
@@ -54,9 +48,9 @@ import Coercion hiding (substCo)
import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon )
import Id
import Class
-import DataCon ( dataConWorkId )
+import DataCon ( dataConWorkId )
import Name
-import MkId ( seqId )
+import MkId ( seqId )
import Var
import VarSet
import Rules
@@ -78,9 +72,9 @@ import Control.Monad(liftM)
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -106,17 +100,17 @@ dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless
= do { dflags <- getDynFlags
; core_expr <- dsLExpr expr
- -- Dictionary bindings are always VarBinds,
- -- so we only need do this here
+ -- Dictionary bindings are always VarBinds,
+ -- so we only need do this here
; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr
- | otherwise = var
+ | otherwise = var
; return (unitOL (makeCorePair dflags var' False 0 core_expr)) }
dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
, fun_co_fn = co_fn, fun_tick = tick
, fun_infix = inf })
- = do { dflags <- getDynFlags
+ = do { dflags <- getDynFlags
; (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
; let body' = mkOptTickBox tick body
; rhs <- dsHsWrapper co_fn (mkLams args body')
@@ -125,17 +119,17 @@ dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
dsHsBind (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty
, pat_ticks = (rhs_tick, var_ticks) })
- = do { body_expr <- dsGuarded grhss ty
+ = do { body_expr <- dsGuarded grhss ty
; let body' = mkOptTickBox rhs_tick body_expr
; sel_binds <- mkSelectorBinds var_ticks pat body'
- -- We silently ignore inline pragmas; no makeCorePair
- -- Not so cool, but really doesn't matter
+ -- We silently ignore inline pragmas; no makeCorePair
+ -- Not so cool, but really doesn't matter
; return (toOL sel_binds) }
- -- A common case: one exported variable
- -- Non-recursive bindings come through this way
- -- So do self-recursive bindings, and recursive bindings
- -- that have been chopped up with type signatures
+ -- A common case: one exported variable
+ -- Non-recursive bindings come through this way
+ -- So do self-recursive bindings, and recursive bindings
+ -- that have been chopped up with type signatures
dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = [export]
, abs_ev_binds = ev_binds, abs_binds = binds })
@@ -143,21 +137,21 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abe_mono = local, abe_prags = prags } <- export
= do { dflags <- getDynFlags
; bind_prs <- ds_lhs_binds binds
- ; let core_bind = Rec (fromOL bind_prs)
+ ; let core_bind = Rec (fromOL bind_prs)
; ds_binds <- dsTcEvBinds ev_binds
; rhs <- dsHsWrapper wrap $ -- Usually the identity
- mkLams tyvars $ mkLams dicts $
- mkCoreLets ds_binds $
+ mkLams tyvars $ mkLams dicts $
+ mkCoreLets ds_binds $
Let core_bind $
Var local
-
- ; (spec_binds, rules) <- dsSpecs rhs prags
- ; let global' = addIdSpecialisations global rules
- main_bind = makeCorePair dflags global' (isDefaultMethod prags)
- (dictArity dicts) rhs
-
- ; return (main_bind `consOL` spec_binds) }
+ ; (spec_binds, rules) <- dsSpecs rhs prags
+
+ ; let global' = addIdSpecialisations global rules
+ main_bind = makeCorePair dflags global' (isDefaultMethod prags)
+ (dictArity dicts) rhs
+
+ ; return (main_bind `consOL` spec_binds) }
dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = exports, abs_ev_binds = ev_binds
@@ -167,39 +161,39 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
; bind_prs <- ds_lhs_binds binds
; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
| (lcl_id, rhs) <- fromOL bind_prs ]
- -- Monomorphic recursion possible, hence Rec
+ -- Monomorphic recursion possible, hence Rec
- locals = map abe_mono exports
- tup_expr = mkBigCoreVarTup locals
- tup_ty = exprType tup_expr
+ locals = map abe_mono exports
+ tup_expr = mkBigCoreVarTup locals
+ tup_ty = exprType tup_expr
; ds_binds <- dsTcEvBinds ev_binds
- ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
- mkCoreLets ds_binds $
- Let core_bind $
- tup_expr
+ ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
+ mkCoreLets ds_binds $
+ Let core_bind $
+ tup_expr
- ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
+ ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
- ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
+ ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = spec_prags })
- = do { tup_id <- newSysLocalDs tup_ty
- ; rhs <- dsHsWrapper wrap $
+ = do { tup_id <- newSysLocalDs tup_ty
+ ; rhs <- dsHsWrapper wrap $
mkLams tyvars $ mkLams dicts $
- mkTupleSelector locals local tup_id $
- mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
+ mkTupleSelector locals local tup_id $
+ mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
- ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
- ; let global' = (global `setInlinePragma` defaultInlinePragma)
+ ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
+ ; let global' = (global `setInlinePragma` defaultInlinePragma)
`addIdSpecialisations` rules
-- Kill the INLINE pragma because it applies to
-- the user written (local) function. The global
- -- Id is just the selector. Hmm.
- ; return ((global', rhs) `consOL` spec_binds) }
+ -- Id is just the selector. Hmm.
+ ; return ((global', rhs) `consOL` spec_binds) }
; export_binds_s <- mapM mk_bind exports
- ; return ((poly_tup_id, poly_tup_rhs) `consOL`
- concatOL export_binds_s) }
+ ; return ((poly_tup_id, poly_tup_rhs) `consOL`
+ concatOL export_binds_s) }
where
inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
-- the inline pragma from the source
@@ -217,14 +211,14 @@ dsHsBind (PatSynBind{}) = panic "dsHsBind: PatSynBind"
------------------------
makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
makeCorePair dflags gbl_id is_default_method dict_arity rhs
- | is_default_method -- Default methods are *always* inlined
+ | is_default_method -- Default methods are *always* inlined
= (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
| otherwise
= case inlinePragmaSpec inline_prag of
- EmptyInlineSpec -> (gbl_id, rhs)
- NoInline -> (gbl_id, rhs)
- Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
+ EmptyInlineSpec -> (gbl_id, rhs)
+ NoInline -> (gbl_id, rhs)
+ Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
Inline -> inline_pair
where
@@ -232,8 +226,8 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs
inlinable_unf = mkInlinableUnfolding dflags rhs
inline_pair
| Just arity <- inlinePragmaSat inline_prag
- -- Add an Unfolding for an INLINE (but not for NOINLINE)
- -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
+ -- Add an Unfolding for an INLINE (but not for NOINLINE)
+ -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
, let real_arity = dict_arity + arity
-- NB: The arity in the InlineRule takes account of the dictionaries
= ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
@@ -264,22 +258,22 @@ Note [Rules and inlining]
Common special case: no type or dictionary abstraction
This is a bit less trivial than you might suppose
The naive way woudl be to desguar to something like
- f_lcl = ...f_lcl... -- The "binds" from AbsBinds
- M.f = f_lcl -- Generated from "exports"
+ f_lcl = ...f_lcl... -- The "binds" from AbsBinds
+ M.f = f_lcl -- Generated from "exports"
But we don't want that, because if M.f isn't exported,
-it'll be inlined unconditionally at every call site (its rhs is
-trivial). That would be ok unless it has RULES, which would
+it'll be inlined unconditionally at every call site (its rhs is
+trivial). That would be ok unless it has RULES, which would
thereby be completely lost. Bad, bad, bad.
Instead we want to generate
- M.f = ...f_lcl...
- f_lcl = M.f
-Now all is cool. The RULES are attached to M.f (by SimplCore),
+ M.f = ...f_lcl...
+ f_lcl = M.f
+Now all is cool. The RULES are attached to M.f (by SimplCore),
and f_lcl is rapidly inlined away.
This does not happen in the same way to polymorphic binds,
because they desugar to
- M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
+ M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
Although I'm a bit worried about whether full laziness might
float the f_lcl binding out and then inline M.f at its call site
@@ -297,7 +291,7 @@ So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
instance RealFrac Float where
{-# SPECIALIZE round :: Float -> Int #-}
-The top-level AbsBinds for $cround has no tyvars or dicts (because the
+The top-level AbsBinds for $cround has no tyvars or dicts (because the
instance does not). But the method is locally overloaded!
Note [Abstracting over tyvars only]
@@ -305,36 +299,36 @@ Note [Abstracting over tyvars only]
When abstracting over type variable only (not dictionaries), we don't really need to
built a tuple and select from it, as we do in the general case. Instead we can take
- AbsBinds [a,b] [ ([a,b], fg, fl, _),
- ([b], gg, gl, _) ]
- { fl = e1
- gl = e2
- h = e3 }
+ AbsBinds [a,b] [ ([a,b], fg, fl, _),
+ ([b], gg, gl, _) ]
+ { fl = e1
+ gl = e2
+ h = e3 }
and desugar it to
- fg = /\ab. let B in e1
- gg = /\b. let a = () in let B in S(e2)
- h = /\ab. let B in e3
+ fg = /\ab. let B in e1
+ gg = /\b. let a = () in let B in S(e2)
+ h = /\ab. let B in e3
where B is the *non-recursive* binding
- fl = fg a b
- gl = gg b
- h = h a b -- See (b); note shadowing!
+ fl = fg a b
+ gl = gg b
+ h = h a b -- See (b); note shadowing!
Notice (a) g has a different number of type variables to f, so we must
- use the mkArbitraryType thing to fill in the gaps.
- We use a type-let to do that.
+ use the mkArbitraryType thing to fill in the gaps.
+ We use a type-let to do that.
- (b) The local variable h isn't in the exports, and rather than
- clone a fresh copy we simply replace h by (h a b), where
- the two h's have different types! Shadowing happens here,
- which looks confusing but works fine.
+ (b) The local variable h isn't in the exports, and rather than
+ clone a fresh copy we simply replace h by (h a b), where
+ the two h's have different types! Shadowing happens here,
+ which looks confusing but works fine.
- (c) The result is *still* quadratic-sized if there are a lot of
- small bindings. So if there are more than some small
- number (10), we filter the binding set B by the free
- variables of the particular RHS. Tiresome.
+ (c) The result is *still* quadratic-sized if there are a lot of
+ small bindings. So if there are more than some small
+ number (10), we filter the binding set B by the free
+ variables of the particular RHS. Tiresome.
Why got to this trouble? It's a common case, and it removes the
quadratic-sized tuple desugaring. Less clutter, hopefullly faster
@@ -350,13 +344,13 @@ Consider
foo x = ...
If (foo d) ever gets floated out as a common sub-expression (which can
-happen as a result of method sharing), there's a danger that we never
+happen as a result of method sharing), there's a danger that we never
get to do the inlining, which is a Terribly Bad thing given that the
user said "inline"!
To avoid this we pre-emptively eta-expand the definition, so that foo
has the arity with which it is declared in the source code. In this
-example it has arity 2 (one for the Eq and one for x). Doing this
+example it has arity 2 (one for the Eq and one for x). Doing this
should mean that (foo d) is a PAP and we don't share it.
Note [Nested arities]
@@ -379,8 +373,8 @@ thought!
Note [Implementing SPECIALISE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Example:
- f :: (Eq a, Ix b) => a -> b -> Bool
- {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
+ f :: (Eq a, Ix b) => a -> b -> Bool
+ {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
f = <poly_rhs>
From this the typechecker generates
@@ -390,7 +384,7 @@ From this the typechecker generates
SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
-> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
-Note that wrap_fn can transform *any* function with the right type prefix
+Note that wrap_fn can transform *any* function with the right type prefix
forall ab. (Eq a, Ix b) => XXX
regardless of XXX. It's sort of polymorphic in XXX. This is
useful: we use the same wrapper to transform each of the class ops, as
@@ -398,26 +392,26 @@ well as the dict.
From these we generate:
- Rule: forall p, q, (dp:Ix p), (dq:Ix q).
+ Rule: forall p, q, (dp:Ix p), (dq:Ix q).
f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
- Spec bind: f_spec = wrap_fn <poly_rhs>
+ Spec bind: f_spec = wrap_fn <poly_rhs>
-Note that
+Note that
* The LHS of the rule may mention dictionary *expressions* (eg
$dfIxPair dp dq), and that is essential because the dp, dq are
needed on the RHS.
- * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
+ * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
can fully specialise it.
\begin{code}
------------------------
dsSpecs :: CoreExpr -- Its rhs
-> TcSpecPrags
- -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids
- , [CoreRule] ) -- Rules for the Global Ids
+ -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids
+ , [CoreRule] ) -- Rules for the Global Ids
-- See Note [Implementing SPECIALISE pragmas]
dsSpecs _ IsDefaultMethod = return (nilOL, [])
dsSpecs poly_rhs (SpecPrags sps)
@@ -425,29 +419,29 @@ dsSpecs poly_rhs (SpecPrags sps)
; let (spec_binds_s, rules) = unzip pairs
; return (concatOL spec_binds_s, rules) }
-dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
- -- Nothing => RULE is for an imported Id
- -- rhs is in the Id's unfolding
+dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
+ -- Nothing => RULE is for an imported Id
+ -- rhs is in the Id's unfolding
-> Located TcSpecPrag
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
| isJust (isClassOpId_maybe poly_id)
- = putSrcSpanDs loc $
- do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector")
+ = putSrcSpanDs loc $
+ do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector")
<+> quotes (ppr poly_id))
; return Nothing } -- There is no point in trying to specialise a class op
- -- Moreover, classops don't (currently) have an inl_sat arity set
- -- (it would be Just 0) and that in turn makes makeCorePair bleat
+ -- Moreover, classops don't (currently) have an inl_sat arity set
+ -- (it would be Just 0) and that in turn makes makeCorePair bleat
- | no_act_spec && isNeverActive rule_act
- = putSrcSpanDs loc $
+ | no_act_spec && isNeverActive rule_act
+ = putSrcSpanDs loc $
do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for NOINLINE function:")
<+> quotes (ppr poly_id))
; return Nothing } -- Function is NOINLINE, and the specialiation inherits that
- -- See Note [Activation pragmas for SPECIALISE]
+ -- See Note [Activation pragmas for SPECIALISE]
| otherwise
- = putSrcSpanDs loc $
+ = putSrcSpanDs loc $
do { uniq <- newUnique
; let poly_name = idName poly_id
spec_occ = mkSpecOcc (getOccName poly_name)
@@ -467,14 +461,14 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
unf_fvs = stableUnfoldingVars fn_unf `orElse` emptyVarSet
in_scope = mkInScopeSet (unf_fvs `unionVarSet` exprsFreeVars args)
spec_unf = specUnfolding dflags (mkEmptySubst in_scope) bndrs args fn_unf
- spec_id = mkLocalId spec_name spec_ty
- `setInlinePragma` inl_prag
- `setIdUnfolding` spec_unf
+ spec_id = mkLocalId spec_name spec_ty
+ `setInlinePragma` inl_prag
+ `setIdUnfolding` spec_unf
rule = mkRule False {- Not auto -} is_local_id
(mkFastString ("SPEC " ++ showPpr dflags poly_name))
- rule_act poly_name
- rule_bndrs args
- (mkVarApps (Var spec_id) bndrs)
+ rule_act poly_name
+ rule_bndrs args
+ (mkVarApps (Var spec_id) bndrs)
; spec_rhs <- dsHsWrapper spec_co poly_rhs
@@ -489,21 +483,21 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
where
is_local_id = isJust mb_poly_rhs
poly_rhs | Just rhs <- mb_poly_rhs
- = rhs -- Local Id; this is its rhs
+ = rhs -- Local Id; this is its rhs
| Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
= unfolding -- Imported Id; this is its unfolding
- -- Use realIdUnfolding so we get the unfolding
- -- even when it is a loop breaker.
- -- We want to specialise recursive functions!
+ -- Use realIdUnfolding so we get the unfolding
+ -- even when it is a loop breaker.
+ -- We want to specialise recursive functions!
| otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
- -- The type checker has checked that it *has* an unfolding
+ -- The type checker has checked that it *has* an unfolding
id_inl = idInlinePragma poly_id
-- See Note [Activation pragmas for SPECIALISE]
inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl
| not is_local_id -- See Note [Specialising imported functions]
- -- in OccurAnal
+ -- in OccurAnal
, isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
| otherwise = id_inl
-- Get the INLINE pragma from SPECIALISE declaration, or,
@@ -522,7 +516,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
specOnInline :: Name -> MsgDoc
-specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:")
+specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:")
<+> quotes (ppr f)
\end{code}
@@ -535,7 +529,7 @@ From a user SPECIALISE pragma for f, we generate
We need two pragma-like things:
-* spec_fn's inline pragma: inherited from f's inline pragma (ignoring
+* spec_fn's inline pragma: inherited from f's inline pragma (ignoring
activation on SPEC), unless overriden by SPEC INLINE
* Activation of RULE: from SPECIALISE pragma (if activation given)
@@ -557,7 +551,7 @@ SPEC [n] f :: ty [n] NOINLINE [k]
copy f's prag
INLINE [k] f
-SPEC [n] f :: ty [n] INLINE [k]
+SPEC [n] f :: ty [n] INLINE [k]
copy f's prag
SPEC INLINE [n] f :: ty [n] INLINE [n]
@@ -569,9 +563,9 @@ SPEC f :: ty [n] INLINE [k]
%************************************************************************
-%* *
+%* *
\subsection{Adding inline pragmas}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -598,11 +592,11 @@ decomposeRuleLhs orig_bndrs orig_lhs
Right (bndrs1, fn_var, args)
| Case scrut bndr ty [(DEFAULT, _, body)] <- fun
- , isDeadBinder bndr -- Note [Matching seqId]
+ , isDeadBinder bndr -- Note [Matching seqId]
, let args' = [Type (idType bndr), Type ty, scrut, body]
= Right (bndrs1, seqId, args' ++ args)
- | otherwise
+ | otherwise
= Left bad_shape_msg
where
lhs1 = drop_dicts orig_lhs
@@ -623,7 +617,7 @@ decomposeRuleLhs orig_bndrs orig_lhs
2 (vcat [ text "Optimised lhs:" <+> ppr lhs2
, text "Orig lhs:" <+> ppr orig_lhs])
dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
- , ptext (sLit "is not bound in RULE lhs")])
+ , ptext (sLit "is not bound in RULE lhs")])
2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
, text "Orig lhs:" <+> ppr orig_lhs
, text "optimised lhs:" <+> ppr lhs2 ])
@@ -633,12 +627,12 @@ decomposeRuleLhs orig_bndrs orig_lhs
| otherwise = ptext (sLit "variable") <+> quotes (ppr bndr)
drop_dicts :: CoreExpr -> CoreExpr
- drop_dicts e
+ drop_dicts e
= wrap_lets needed bnds body
where
needed = orig_bndr_set `minusVarSet` exprFreeVars body
(bnds, body) = split_lets (occurAnalyseExpr e)
- -- The occurAnalyseExpr drops dead bindings which is
+ -- The occurAnalyseExpr drops dead bindings which is
-- crucial to ensure that every binding is used later;
-- which in turn makes wrap_lets work right
@@ -663,22 +657,22 @@ decomposeRuleLhs orig_bndrs orig_lhs
Note [Decomposing the left-hand side of a RULE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are several things going on here.
+There are several things going on here.
* drop_dicts: see Note [Drop dictionary bindings on rule LHS]
* simpleOptExpr: see Note [Simplify rule LHS]
* extra_dict_bndrs: see Note [Free dictionaries]
Note [Drop dictionary bindings on rule LHS]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-drop_dicts drops dictionary bindings on the LHS where possible.
+drop_dicts drops dictionary bindings on the LHS where possible.
E.g. let d:Eq [Int] = $fEqList $fEqInt in f d
--> f d
- Reasoning here is that there is only one d:Eq [Int], and so we can
+ Reasoning here is that there is only one d:Eq [Int], and so we can
quantify over it. That makes 'd' free in the LHS, but that is later
picked up by extra_dict_bndrs (Note [Dead spec binders]).
NB 1: We can only drop the binding if the RHS doesn't bind
- one of the orig_bndrs, which we assume occur on RHS.
+ one of the orig_bndrs, which we assume occur on RHS.
Example
f :: (Eq a) => b -> a -> a
{-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}
@@ -687,7 +681,7 @@ drop_dicts drops dictionary bindings on the LHS where possible.
Of course, the ($dfEqlist d) in the pattern makes it less likely
to match, but ther is no other way to get d:Eq a
- NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all
+ NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all
the evidence bindings to be wrapped around the outside of the
LHS. (After simplOptExpr they'll usually have been inlined.)
dsHsWrapper does dependency analysis, so that civilised ones
@@ -728,39 +722,39 @@ Note [Simplify rule LHS]
~~~~~~~~~~~~~~~~~~~~~~~~
simplOptExpr occurrence-analyses and simplifies the LHS:
- (a) Inline any remaining dictionary bindings (which hopefully
+ (a) Inline any remaining dictionary bindings (which hopefully
occur just once)
(b) Substitute trivial lets so that they don't get in the way
- Note that we substitute the function too; we might
+ Note that we substitute the function too; we might
have this as a LHS: let f71 = M.f Int in f71
- (c) Do eta reduction. To see why, consider the fold/build rule,
+ (c) Do eta reduction. To see why, consider the fold/build rule,
which without simplification looked like:
fold k z (build (/\a. g a)) ==> ...
This doesn't match unless you do eta reduction on the build argument.
Similarly for a LHS like
- augment g (build h)
+ augment g (build h)
we do not want to get
- augment (\a. g a) (build h)
+ augment (\a. g a) (build h)
otherwise we don't match when given an argument like
augment (\a. h a a) (build h)
Note [Matching seqId]
~~~~~~~~~~~~~~~~~~~
The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
-and this code turns it back into an application of seq!
+and this code turns it back into an application of seq!
See Note [Rules for seq] in MkId for the details.
Note [Unused spec binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
- f :: a -> a
- {-# SPECIALISE f :: Eq a => a -> a #-}
+ f :: a -> a
+ {-# SPECIALISE f :: Eq a => a -> a #-}
It's true that this *is* a more specialised type, but the rule
we get is something like this:
- f_spec d = f
- RULE: f = f_spec d
+ f_spec d = f
+ RULE: f = f_spec d
Note that the rule is bogus, because it mentions a 'd' that is
not bound on the LHS! But it's a silly specialisation anyway, because
the constraint is unused. We could bind 'd' to (error "unused")
@@ -769,22 +763,22 @@ a mistake. That's what the isDeadBinder call detects.
Note [Free dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~
-When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
-which is presumably in scope at the function definition site, we can quantify
+When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
+which is presumably in scope at the function definition site, we can quantify
over it too. *Any* dict with that type will do.
So for example when you have
- f :: Eq a => a -> a
- f = <rhs>
- {-# SPECIALISE f :: Int -> Int #-}
+ f :: Eq a => a -> a
+ f = <rhs>
+ {-# SPECIALISE f :: Int -> Int #-}
Then we get the SpecPrag
- SpecPrag (f Int dInt)
+ SpecPrag (f Int dInt)
And from that we want the rule
-
- RULE forall dInt. f Int dInt = f_spec
- f_spec = let f = <rhs> in f Int dInt
+
+ RULE forall dInt. f Int dInt = f_spec
+ f_spec = let f = <rhs> in f Int dInt
But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
Name, and you can't bind them in a lambda or forall without getting things
@@ -794,23 +788,23 @@ as the old one, but with an Internal name and no IdInfo.
%************************************************************************
-%* *
- Desugaring evidence
-%* *
+%* *
+ Desugaring evidence
+%* *
%************************************************************************
\begin{code}
dsHsWrapper :: HsWrapper -> CoreExpr -> DsM CoreExpr
-dsHsWrapper WpHole e = return e
+dsHsWrapper WpHole e = return e
dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty)
dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds
return (mkCoreLets bs e)
dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 =<< dsHsWrapper c2 e
dsHsWrapper (WpCast co) e = ASSERT(tcCoercionRole co == Representational)
dsTcCoercion co (mkCast e)
-dsHsWrapper (WpEvLam ev) e = return $ Lam ev e
-dsHsWrapper (WpTyLam tv) e = return $ Lam tv e
+dsHsWrapper (WpEvLam ev) e = return $ Lam ev e
+dsHsWrapper (WpTyLam tv) e = return $ Lam tv e
dsHsWrapper (WpEvApp evtrm) e = liftM (App e) (dsEvTerm evtrm)
--------------------------------------
@@ -830,7 +824,7 @@ sccEvBinds :: Bag EvBind -> [SCC EvBind]
sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
where
edges :: [(EvBind, EvVar, [EvVar])]
- edges = foldrBag ((:) . mk_node) [] bs
+ edges = foldrBag ((:) . mk_node) [] bs
mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
mk_node b@(EvBind var term) = (b, var, varSetElems (evVarsOfTerm term))
@@ -840,7 +834,7 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm (EvId v) = return (Var v)
-dsEvTerm (EvCast tm co)
+dsEvTerm (EvCast tm co)
= do { tm' <- dsEvTerm tm
; dsTcCoercion co $ mkCast tm' }
-- 'v' is always a lifted evidence variable so it is
@@ -856,29 +850,29 @@ dsEvTerm (EvTupleSel v n)
= do { tm' <- dsEvTerm v
; let scrut_ty = exprType tm'
(tc, tys) = splitTyConApp scrut_ty
- Just [dc] = tyConDataCons_maybe tc
- xs = mkTemplateLocals tys
+ Just [dc] = tyConDataCons_maybe tc
+ xs = mkTemplateLocals tys
the_x = getNth xs n
; ASSERT( isTupleTyCon tc )
return $
Case tm' (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] }
-dsEvTerm (EvTupleMk tms)
+dsEvTerm (EvTupleMk tms)
= do { tms' <- mapM dsEvTerm tms
; let tys = map exprType tms'
; return $ Var (dataConWorkId dc) `mkTyApps` tys `mkApps` tms' }
- where
+ where
dc = tupleCon ConstraintTuple (length tms)
dsEvTerm (EvSuperClass d n)
= do { d' <- dsEvTerm d
; let (cls, tys) = getClassPredTys (exprType d')
- sc_sel_id = classSCSelId cls n -- Zero-indexed
+ sc_sel_id = classSCSelId cls n -- Zero-indexed
; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
where
dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
- where
+ where
errorId = rUNTIME_ERROR_ID
litMsg = Lit (MachStr (fastStringToByteString msg))
@@ -889,7 +883,7 @@ dsEvTerm (EvLit l) =
---------------------------------------
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
--- This is the crucial function that moves
+-- This is the crucial function that moves
-- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
-- e.g. dsTcCoercion (trans g1 g2) k
-- = case g1 of EqBox g1# ->
@@ -927,7 +921,7 @@ ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion
-- If the incoming TcCoercion if of type (a ~ b) (resp. Coercible a b)
-- the result is of type (a ~# b) (reps. a ~# b)
-- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b) (resp. and so on)
--- No need for InScope set etc because the
+-- No need for InScope set etc because the
ds_tc_coercion subst tc_co
= go tc_co
where
@@ -978,7 +972,7 @@ Note [Simple coercions]
We have a special case for coercions that are simple variables.
Suppose cv :: a ~ b is in scope
Lacking the special case, if we see
- f a b cv
+ f a b cv
we'd desguar to
f a b (case cv of EqBox (cv# :: a ~# b) -> EqBox cv#)
which is a bit stupid. The special case does the obvious thing.
@@ -990,7 +984,7 @@ This turns out to be important when desugaring the LHS of a RULE
{-# RULES "normalise" normalise = normalise_Double #-}
Then the RULE we want looks like
- forall a, (cv:a~Scalar a).
+ forall a, (cv:a~Scalar a).
normalise a cv = normalise_Double
But without the special case we generate the redundant box/unbox,
which simpleOpt (currently) doesn't remove. So the rule never matches.