X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=baf2a3097a3c47a80437cd08883407d680a76403;hb=8e15cfb601a904523a39079aa7c55e729ccbffda;hp=514263231c787513ee284f96c4468a20c63fdba6;hpb=43d903cfaafb0b41242af128c7ddbf0b649f63bd;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 5142632..baf2a30 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -4,6 +4,13 @@ \section[Simplify]{The main module of the simplifier} \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module Simplify ( simplTopBinds, simplExpr ) where #include "HsVersions.h" @@ -32,6 +39,7 @@ import PrelInfo ( realWorldPrimId ) import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..), isNonRuleLoopBreaker ) import Maybes ( orElse ) +import Data.List ( mapAccumL ) import Outputable import Util \end{code} @@ -227,8 +235,10 @@ simplTopBinds env binds trace True bind = pprTrace "SimplBind" (ppr (bindersOf bind)) trace False bind = \x -> x - simpl_bind env (NonRec b r) = simplRecOrTopPair env TopLevel b r - simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs + simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs + simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r + where + (env', b') = addBndrRules env b (lookupRecBndr env b) \end{code} @@ -246,15 +256,22 @@ simplRecBind :: SimplEnv -> TopLevelFlag -> [(InId, InExpr)] -> SimplM SimplEnv simplRecBind env top_lvl pairs - = do { env' <- go (zapFloats env) pairs + = do { let (env_with_info, triples) = mapAccumL add_rules env pairs + ; env' <- go (zapFloats env_with_info) triples ; return (env `addRecFloats` env') } -- addFloats adds the floats from env', -- *and* updates env with the in-scope set from env' where + add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr)) + -- Add the (substituted) rules to the binder + add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs)) + where + (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr) + go env [] = return env - go env ((bndr, rhs) : pairs) - = do { env <- simplRecOrTopPair env top_lvl bndr rhs + go env ((old_bndr, new_bndr, rhs) : pairs) + = do { env <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs ; go env pairs } \end{code} @@ -267,18 +284,16 @@ It assumes the binder has already been simplified, but not its IdInfo. \begin{code} simplRecOrTopPair :: SimplEnv -> TopLevelFlag - -> InId -> InExpr -- Binder and rhs + -> InId -> OutBndr -> InExpr -- Binder and rhs -> SimplM SimplEnv -- Returns an env that includes the binding -simplRecOrTopPair env top_lvl bndr rhs - | preInlineUnconditionally env top_lvl bndr rhs -- Check for unconditional inline - = do { tick (PreInlineUnconditionally bndr) - ; return (extendIdSubst env bndr (mkContEx env rhs)) } +simplRecOrTopPair env top_lvl old_bndr new_bndr rhs + | preInlineUnconditionally env top_lvl old_bndr rhs -- Check for unconditional inline + = do { tick (PreInlineUnconditionally old_bndr) + ; return (extendIdSubst env old_bndr (mkContEx env rhs)) } | otherwise - = do { let bndr' = lookupRecBndr env bndr - (env', bndr'') = addLetIdInfo env bndr bndr' - ; simplLazyBind env' top_lvl Recursive bndr bndr'' rhs env' } + = simplLazyBind env top_lvl Recursive old_bndr new_bndr rhs env -- May not actually be recursive, but it doesn't matter \end{code} @@ -415,6 +430,8 @@ That's what the 'go' loop in prepareRhs does prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Adds new floats to the env iff that allows us to return a good RHS prepareRhs env (Cast rhs co) -- Note [Float coercions] + | (ty1, ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type + , not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)] = do { (env', rhs') <- makeTrivial env rhs ; return (env', Cast rhs' co) } @@ -467,6 +484,22 @@ and lead to further optimisation. Example: go n = case x of { T m -> go (n-m) } -- This case should optimise +Note [Float coercions (unlifted)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +BUT don't do [Float coercions] if 'e' has an unlifted type. +This *can* happen: + + foo :: Int = (error (# Int,Int #) "urk") + `cast` CoUnsafe (# Int,Int #) Int + +If do the makeTrivial thing to the error call, we'll get + foo = case error (# Int,Int #) "urk" of v -> v `cast` ... +But 'v' isn't in scope! + +These strange casts can happen as a result of case-of-case + bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of + (# p,q #) -> p+q + \begin{code} makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) @@ -553,6 +586,8 @@ completeBind env top_lvl old_bndr new_bndr new_rhs -- (for example) be no longer strictly demanded. -- The solution here is a bit ad hoc... info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding + `setWorkerInfo` worker_info + final_info | loop_breaker = new_bndr_info | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf | otherwise = info_w_unf @@ -566,6 +601,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs return (addNonRec env final_id new_rhs) where unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs + worker_info = substWorker env (workerInfo old_info) loop_breaker = isNonRuleLoopBreaker occ_info old_info = idInfo old_bndr occ_info = occInfo old_info @@ -871,9 +907,10 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont (StrictBind bndr bndrs body env cont) } | otherwise - = do { (env, bndr') <- simplNonRecBndr env bndr - ; env <- simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se - ; simplLam env bndrs body cont } + = do { (env1, bndr1) <- simplNonRecBndr env bndr + ; let (env2, bndr2) = addBndrRules env1 bndr bndr1 + ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se + ; simplLam env3 bndrs body cont } \end{code} @@ -892,10 +929,10 @@ simplNote env (SCC cc) e cont -- See notes with SimplMonad.inlineMode simplNote env InlineMe e cont - | contIsRhsOrArg cont -- Totally boring continuation; see notes above + | Just (inside, outside) <- splitInlineCont cont -- Boring boring continuation; see notes above = do { -- Don't inline inside an INLINE expression - e' <- simplExpr (setMode inlineMode env) e - ; rebuild env (mkInlineMe e') cont } + e' <- simplExprC (setMode inlineMode env) e inside + ; rebuild env (mkInlineMe e') outside } | otherwise -- Dissolve the InlineMe note if there's -- an interesting context of any kind to combine with @@ -952,8 +989,8 @@ completeCall env var cont -- the wrapper didn't occur for things that have specialisations till a -- later phase, so but now we just try RULES first -- - -- Note [Self-recursive rules] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Note [Rules for recursive functions] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- You might think that we shouldn't apply rules for a loop breaker: -- doing so might give rise to an infinite loop, because a RULE is -- rather like an extra equation for the function: @@ -990,17 +1027,15 @@ completeCall env var cont ------------- Next try inlining ---------------- { let arg_infos = [interestingArg arg | arg <- args, isValArg arg] n_val_args = length arg_infos - interesting_cont = interestingCallContext (notNull args) - (notNull arg_infos) - call_cont + interesting_cont = interestingCallContext call_cont active_inline = activeInline env var - maybe_inline = callSiteInline dflags active_inline - var arg_infos interesting_cont + maybe_inline = callSiteInline dflags active_inline var + (null args) arg_infos interesting_cont ; case maybe_inline of { Just unfolding -- There is an inlining! -> do { tick (UnfoldingDone var) ; (if dopt Opt_D_dump_inlinings dflags then - pprTrace "Inlining done" (vcat [ + pprTrace ("Inlining done" ++ showSDoc (ppr var)) (vcat [ text "Before:" <+> ppr var <+> sep (map pprParendExpr args), text "Inlined fn: " <+> nest 2 (ppr unfolding), text "Cont: " <+> ppr call_cont]) @@ -1294,7 +1329,7 @@ where x::F Int. Then we'd like to rewrite (F Int) to Int, getting I# x# -> let x = x' `cast` sym co in rhs -so that 'rhs' can take advantage of hte form of x'. Notice that Note +so that 'rhs' can take advantage of the form of x'. Notice that Note [Case of cast] may then apply to the result. This showed up in Roman's experiments. Example: @@ -1430,7 +1465,7 @@ simplCaseBinder env scrut case_bndr alts -- See Note [no-case-of-case] = (env, case_bndr) - | otherwise -- Failed try [see Note 2 above] + | otherwise -- Failed try; see Note [Suppressing the case binder-swap] -- not (isEvaldUnfolding (idUnfolding v)) = case scrut of Var v -> (modifyInScope env1 v case_bndr', case_bndr') @@ -1508,7 +1543,7 @@ simplAlts env scrut case_bndr alts cont' do { let alt_env = zapFloats env ; (alt_env, scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts - ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut case_bndr' alts + ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env scrut case_bndr' alts ; alts' <- mapM (simplAlt alt_env imposs_deflt_cons case_bndr' cont') in_alts ; return (scrut', case_bndr', alts') } @@ -1537,19 +1572,19 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (LitAlt lit, bndrs, rhs) simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs) = do { -- Deal with the pattern-bound variables - (env, vs') <- simplBinders env (add_evals con vs) - -- Mark the ones that are in ! positions in the -- data constructor as certainly-evaluated. - ; let vs'' = add_evals con vs' + -- NB: simplLamBinders preserves this eval info + let vs_with_evals = add_evals vs (dataConRepStrictness con) + ; (env, vs') <- simplLamBndrs env vs_with_evals -- Bind the case-binder to (con args) ; let inst_tys' = tyConAppArgs (idType case_bndr') - con_args = map Type inst_tys' ++ varsToCoreExprs vs'' + con_args = map Type inst_tys' ++ varsToCoreExprs vs' env' = addBinderUnfolding env case_bndr' (mkConApp con con_args) ; rhs' <- simplExprC env' rhs cont' - ; return (DataAlt con, vs'', rhs') } + ; return (DataAlt con, vs', rhs') } where -- add_evals records the evaluated-ness of the bound variables of -- a case pattern. This is *important*. Consider @@ -1560,9 +1595,7 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs) -- We really must record that b is already evaluated so that we don't -- go and re-evaluate it when constructing the result. -- See Note [Data-con worker strictness] in MkId.lhs - add_evals dc vs = cat_evals dc vs (dataConRepStrictness dc) - - cat_evals dc vs strs + add_evals vs strs = go vs strs where go [] [] = [] @@ -1573,12 +1606,15 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs) where zapped_v = zap_occ_info v evald_v = zapped_v `setIdUnfolding` evaldUnfolding - go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs) + go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr strs) - -- If the case binder is alive, then we add the unfolding + -- zap_occ_info: if the case binder is alive, then we add the unfolding -- case_bndr = C vs -- to the envt; so vs are now very much alive - -- Note [Aug06] I can't see why this actually matters + -- Note [Aug06] I can't see why this actually matters, but it's neater + -- case e of t { (a,b) -> ...(case t of (p,q) -> p)... } + -- ==> case e of t { (a,b) -> ...(a)... } + -- Look, Ma, a is alive now. zap_occ_info | isDeadBinder case_bndr' = \id -> id | otherwise = zapOccInfo @@ -1655,25 +1691,27 @@ knownAlt env scrut args bndr (DataAlt dc, bs, rhs) cont ; env <- simplNonRecX env bndr bndr_rhs ; -- pprTrace "knownCon2" (ppr bs $$ ppr rhs $$ ppr (seIdSubst env)) $ simplExprF env rhs cont } - --- Ugh! -bind_args env dead_bndr [] _ = return env - -bind_args env dead_bndr (b:bs) (Type ty : args) - = ASSERT( isTyVar b ) - bind_args (extendTvSubst env b ty) dead_bndr bs args - -bind_args env dead_bndr (b:bs) (arg : args) - = ASSERT( isId b ) - do { let b' = if dead_bndr then b else zapOccInfo b - -- Note that the binder might be "dead", because it doesn't occur - -- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally - -- Nevertheless we must keep it if the case-binder is alive, because it may - -- be used in the con_app. See Note [zapOccInfo] - ; env <- simplNonRecX env b' arg - ; bind_args env dead_bndr bs args } - -bind_args _ _ _ _ = panic "bind_args" + where + -- Ugh! + bind_args env dead_bndr [] _ = return env + + bind_args env dead_bndr (b:bs) (Type ty : args) + = ASSERT( isTyVar b ) + bind_args (extendTvSubst env b ty) dead_bndr bs args + + bind_args env dead_bndr (b:bs) (arg : args) + = ASSERT( isId b ) + do { let b' = if dead_bndr then b else zapOccInfo b + -- Note that the binder might be "dead", because it doesn't occur + -- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally + -- Nevertheless we must keep it if the case-binder is alive, because it may + -- be used in the con_app. See Note [zapOccInfo] + ; env <- simplNonRecX env b' arg + ; bind_args env dead_bndr bs args } + + bind_args _ _ _ _ = + pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr args $$ + text "scrut:" <+> ppr scrut \end{code}