diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2014-09-26 12:58:41 +0100 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2014-09-26 13:55:11 +0100 |
commit | 0ef1cc67dc472493b7dee1a28dedbfe938536b8f (patch) | |
tree | 59aa09b676707607792fd8a0430ba23afc608839 /compiler/deSugar/DsBinds.lhs | |
parent | ac157de3cd959a18a71fa056403675e2c0563497 (diff) | |
download | haskell-0ef1cc67dc472493b7dee1a28dedbfe938536b8f.tar.gz |
De-tabify and remove trailing whitespace
Diffstat (limited to 'compiler/deSugar/DsBinds.lhs')
-rw-r--r-- | compiler/deSugar/DsBinds.lhs | 348 |
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. |