X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=121e9b5fdf93eada3f4535d4465c4e6fe98e1403;hb=e8883060ab278b5d4ceda2e75780a302146015c6;hp=06af5ad251282d31f633ff840925e8ee3f219206;hpb=f25b9225f77ca8aa097a9acb4b5be27daea94891;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 06af5ad..121e9b5 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -8,7 +8,7 @@ module Simplify ( simplTopBinds, simplExpr ) where #include "HsVersions.h" -import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings), +import DynFlags ( dopt, DynFlag(Opt_D_dump_inlinings), SimplifierSwitch(..) ) import SimplMonad @@ -24,7 +24,7 @@ import SimplUtils ( mkCase, mkLam, prepareAlts, import Id ( Id, idType, idInfo, idArity, isDataConWorkId, setIdUnfolding, isDeadBinder, idNewDemandInfo, setIdInfo, - setIdOccInfo, zapLamIdInfo, setOneShotLambda, + setIdOccInfo, zapLamIdInfo, setOneShotLambda ) import MkId ( eRROR_ID ) import Literal ( mkStringLit ) @@ -40,10 +40,10 @@ import DataCon ( dataConTyCon, dataConRepStrictness, isVanillaDataCon ) import TyCon ( tyConArity ) import CoreSyn import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreUnfold ( mkOtherCon, mkUnfolding, evaldUnfolding, callSiteInline ) +import CoreUnfold ( mkUnfolding, callSiteInline ) import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding, exprIsConApp_maybe, mkPiTypes, findAlt, - exprType, exprIsValue, + exprType, exprIsHNF, exprOkForSpeculation, exprArity, mkCoerce, mkCoerce2, mkSCC, mkInlineMe, applyTypeToArg ) @@ -60,7 +60,6 @@ import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..), isNonRec ) import OrdList -import Maybe ( Maybe ) import Maybes ( orElse ) import Outputable import Util ( notNull ) @@ -299,12 +298,14 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside #endif simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside - | preInlineUnconditionally env NotTopLevel bndr + = simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside + +simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside + | preInlineUnconditionally env NotTopLevel bndr rhs = tick (PreInlineUnconditionally bndr) `thenSmpl_` thing_inside (extendIdSubst env bndr (mkContEx rhs_se rhs)) - - | isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let + | isStrictDmd (idNewDemandInfo bndr) || isStrictType bndr_ty -- A strict let = -- Don't use simplBinder because that doesn't keep -- fragile occurrence info in the substitution simplLetBndr env bndr `thenSmpl` \ (env, bndr1) -> @@ -317,7 +318,13 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr) env2 = modifyInScope env1 bndr2 bndr2 in - completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside + if needsCaseBinding bndr_ty rhs1 + then + thing_inside env2 `thenSmpl` \ (floats, body) -> + returnSmpl (emptyFloats env2, Case rhs1 bndr2 (exprType body) + [(DEFAULT, [], wrapFloats floats body)]) + else + completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside | otherwise -- Normal, lazy case = -- Don't use simplBinder because that doesn't keep @@ -326,6 +333,9 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) -> addFloats env floats thing_inside + + where + bndr_ty = idType bndr \end{code} A specialised variant of simplNonRec used when the RHS is already simplified, notably @@ -352,7 +362,7 @@ simplNonRecX env bndr new_rhs thing_inside let body' = wrapFloats floats body in returnSmpl (emptyFloats env, Case new_rhs bndr' (exprType body') [(DEFAULT, [], body')]) - | preInlineUnconditionally env NotTopLevel bndr + | preInlineUnconditionally env NotTopLevel bndr new_rhs -- This happens; for example, the case_bndr during case of -- known constructor: case (a,b) of x { (p,q) -> ... } -- Here x isn't mentioned in the RHS, so we don't want to @@ -421,8 +431,8 @@ simplRecOrTopPair :: SimplEnv -> SimplM (FloatsWith SimplEnv) simplRecOrTopPair env top_lvl bndr bndr' rhs - | preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline - = tick (PreInlineUnconditionally bndr) `thenSmpl_` + | preInlineUnconditionally env top_lvl bndr rhs -- Check for unconditional inline + = tick (PreInlineUnconditionally bndr) `thenSmpl_` returnSmpl (emptyFloats env, extendIdSubst env bndr (mkContEx env rhs)) | otherwise @@ -513,24 +523,24 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se if isEmptyFloats floats && isNilOL aux_binds then -- Shortcut a common case completeLazyBind env1 top_lvl bndr bndr2 rhs2 - else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then + else if is_top_level || exprIsTrivial rhs2 || exprIsHNF rhs2 then -- WARNING: long dodgy argument coming up -- WANTED: a better way to do this -- - -- We can't use "exprIsCheap" instead of exprIsValue, + -- We can't use "exprIsCheap" instead of exprIsHNF, -- because that causes a strictness bug. -- x = let y* = E in case (scc y) of { T -> F; F -> T} -- The case expression is 'cheap', but it's wrong to transform to -- y* = E; x = case (scc y) of {...} -- Either we must be careful not to float demanded non-values, or - -- we must use exprIsValue for the test, which ensures that the - -- thing is non-strict. So exprIsValue => bindings are non-strict + -- we must use exprIsHNF for the test, which ensures that the + -- thing is non-strict. So exprIsHNF => bindings are non-strict -- I think. The WARN below tests for this. -- -- We use exprIsTrivial here because we want to reveal lone variables. -- E.g. let { x = letrec { y = E } in y } in ... -- Here we definitely want to float the y=E defn. - -- exprIsValue definitely isn't right for that. + -- exprIsHNF definitely isn't right for that. -- -- Again, the floated binding can't be strict; if it's recursive it'll -- be non-strict; if it's non-recursive it'd be inlined. @@ -604,7 +614,7 @@ completeLazyBind :: SimplEnv -- (as usual) use the in-scope-env from the floats completeLazyBind env top_lvl old_bndr new_bndr new_rhs - | postInlineUnconditionally env new_bndr occ_info new_rhs + | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding = -- Drop the binding tick (PostInlineUnconditionally old_bndr) `thenSmpl_` returnSmpl (emptyFloats env, extendIdSubst env old_bndr (DoneEx new_rhs)) @@ -635,7 +645,6 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs -- After inling f at some of its call sites the original binding may -- (for example) be no longer strictly demanded. -- The solution here is a bit ad hoc... - unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding final_info | loop_breaker = new_bndr_info | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf @@ -649,6 +658,7 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs returnSmpl (unitFloat env final_id new_rhs, env) where + unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs loop_breaker = isLoopBreaker occ_info old_info = idInfo old_bndr occ_info = occInfo old_info @@ -833,6 +843,11 @@ mkLamBndrZapper fun n_args \begin{code} simplNote env (Coerce to from) body cont = let + addCoerce s1 k1 cont -- Drop redundant coerces. This can happen if a polymoprhic + -- (coerce a b e) is instantiated with a=ty1 b=ty2 and the + -- two are the same. This happens a lot in Happy-generated parsers + | s1 `coreEqType` k1 = cont + addCoerce s1 k1 (CoerceIt t1 cont) -- coerce T1 S1 (coerce S1 K1 e) -- ==> @@ -843,9 +858,9 @@ simplNote env (Coerce to from) body cont -- we may find (coerce T (coerce S (\x.e))) y -- and we'd like it to simplify to e[y/x] in one round -- of simplification - | t1 `coreEqType` k1 = cont -- The coerces cancel out - | otherwise = CoerceIt t1 cont -- They don't cancel, but - -- the inner one is redundant + | t1 `coreEqType` k1 = cont -- The coerces cancel out + | otherwise = CoerceIt t1 cont -- They don't cancel, but + -- the inner one is redundant addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont) | not (isTypeArg arg), -- This whole case only works for value args @@ -1001,6 +1016,13 @@ completeCall env var occ_info cont case maybe_inline of { Just unfolding -- There is an inlining! -> tick (UnfoldingDone var) `thenSmpl_` + (if dopt Opt_D_dump_inlinings dflags then + pprTrace "Inlining done" (vcat [ + text "Before:" <+> ppr var <+> sep (map pprParendExpr args), + text "Inlined fn: " <+> ppr unfolding, + text "Cont: " <+> ppr call_cont]) + else + id) $ makeThatCall env var unfolding args call_cont ; @@ -1303,9 +1325,10 @@ rebuildCase env scrut case_bndr alts cont = knownCon env (LitAlt lit) [] case_bndr alts cont | otherwise - = prepareAlts scrut case_bndr alts `thenSmpl` \ (better_alts, handled_cons) -> + = -- Prepare the alternatives. + prepareAlts scrut case_bndr alts `thenSmpl` \ (better_alts, handled_cons) -> - -- Deal with the case binder, and prepare the continuation; + -- Prepare the continuation; -- The new subst_env is in place prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> addFloats env floats $ \ env -> @@ -1322,7 +1345,7 @@ rebuildCase env scrut case_bndr alts cont res_ty' = contResultType dup_cont in - -- Deal with variable scrutinee + -- Deal with case binder simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr') -> -- Deal with the case alternatives