X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=5ea0a91007d35fe3319a558a6af4c5bf8f45f967;hb=931a117d6236076788c560fb2e08c538be95bd45;hp=610882d3cc873e05a326356d1fb5dfcb9b6f3201;hpb=196ccd219fb3b7bdd4dc24e8804da8640af83bb2;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 610882d..5ea0a91 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -28,7 +28,6 @@ import Id ( Id, idType, idInfo, idArity, isDataConWorkId, ) import MkId ( eRROR_ID ) import Literal ( mkStringLit ) -import OccName ( encodeFS ) import IdInfo ( OccInfo(..), isLoopBreaker, setArityInfo, zapDemandInfo, setUnfoldingInfo, @@ -40,7 +39,7 @@ 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, exprIsHNF, @@ -53,14 +52,14 @@ import CostCentre ( currentCCS ) import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy, splitFunTy_maybe, splitFunTy, coreEqType ) -import VarEnv ( elemVarEnv ) +import VarEnv ( elemVarEnv, emptyVarEnv ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..), isNonRec ) +import StaticFlags ( opt_PprStyle_Debug ) import OrdList -import Maybe ( Maybe ) import Maybes ( orElse ) import Outputable import Util ( notNull ) @@ -234,7 +233,7 @@ simplTopBinds env binds -- so that if a transformation rule has unexpectedly brought -- anything into scope, then we don't get a complaint about that. -- It's rather as if the top-level binders were imported. - simplLetBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') -> + simplRecBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') -> simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) -> freeTick SimplifierDone `thenSmpl_` returnSmpl (floatBinds floats) @@ -309,15 +308,12 @@ simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside | 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) -> + simplNonRecBndr env bndr `thenSmpl` \ (env, bndr1) -> simplStrictArg AnRhs env rhs rhs_se (idType bndr1) cont_ty $ \ env1 rhs1 -> -- Now complete the binding and simplify the body let - -- simplLetBndr doesn't deal with the IdInfo, so we must - -- do so here (c.f. simplLazyBind) - bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr) - env2 = modifyInScope env1 bndr2 bndr2 + (env2,bndr2) = addLetIdInfo env1 bndr bndr1 in if needsCaseBinding bndr_ty rhs1 then @@ -330,7 +326,7 @@ simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside | otherwise -- Normal, lazy case = -- Don't use simplBinder because that doesn't keep -- fragile occurrence info in the substitution - simplLetBndr env bndr `thenSmpl` \ (env, bndr') -> + simplNonRecBndr env bndr `thenSmpl` \ (env, bndr') -> simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) -> addFloats env floats thing_inside @@ -467,42 +463,12 @@ simplLazyBind :: SimplEnv -> SimplM (FloatsWith SimplEnv) simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se - = let -- Transfer the IdInfo of the original binder to the new binder - -- This is crucial: we must preserve - -- strictness - -- rules - -- worker info - -- etc. To do this we must apply the current substitution, - -- which incorporates earlier substitutions in this very letrec group. - -- - -- NB 1. We do this *before* processing the RHS of the binder, so that - -- its substituted rules are visible in its own RHS. - -- This is important. Manuel found cases where he really, really - -- wanted a RULE for a recursive function to apply in that function's - -- own right-hand side. - -- - -- NB 2: We do not transfer the arity (see Subst.substIdInfo) - -- The arity of an Id should not be visible - -- in its own RHS, else we eta-reduce - -- f = \x -> f x - -- to - -- f = f - -- which isn't sound. And it makes the arity in f's IdInfo greater than - -- the manifest arity, which isn't good. - -- The arity will get added later. - -- - -- NB 3: It's important that we *do* transer the loop-breaker OccInfo, - -- because that's what stops the Id getting inlined infinitely, in the body - -- of the letrec. - - -- NB 4: does no harm for non-recursive bindings - - bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr) - env1 = modifyInScope env bndr2 bndr2 + = let + (env1,bndr2) = addLetIdInfo env bndr bndr1 rhs_env = setInScope rhs_se env1 is_top_level = isTopLevel top_lvl ok_float_unlifted = not is_top_level && isNonRec is_rec - rhs_cont = mkRhsStop (idType bndr1) + rhs_cont = mkRhsStop (idType bndr2) in -- Simplify the RHS; note the mkRhsStop, which tells -- the simplifier that this is the RHS of a let. @@ -757,7 +723,7 @@ simplExprF env (Case scrut bndr case_ty alts) cont case_ty' = substTy env case_ty -- c.f. defn of simplExpr simplExprF env (Let (Rec pairs) body) cont - = simplLetBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') -> + = simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') -> -- NB: bndrs' don't have unfoldings or rules -- We add them as we go down @@ -844,6 +810,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) -- ==> @@ -854,9 +825,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 @@ -1321,9 +1292,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 -> @@ -1340,7 +1312,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 @@ -1467,20 +1439,22 @@ simplAlts :: SimplEnv -> SimplM [OutAlt] -- Includes the continuation simplAlts env handled_cons case_bndr' alts cont' - = mapSmpl simpl_alt alts + = do { mb_alts <- mapSmpl simpl_alt alts + ; return [alt' | Just (_, alt') <- mb_alts] } + -- Filter out the alternatives that are inaccessible where - simpl_alt alt = simplAlt env handled_cons case_bndr' alt cont' `thenSmpl` \ (_, alt') -> - returnSmpl alt' + simpl_alt alt = simplAlt env handled_cons case_bndr' alt cont' simplAlt :: SimplEnv -> [AltCon] -> OutId -> InAlt -> SimplCont - -> SimplM (Maybe TvSubstEnv, OutAlt) + -> SimplM (Maybe (TvSubstEnv, OutAlt)) -- Simplify an alternative, returning the type refinement for the -- alternative, if the alternative does any refinement at all +-- Nothing => the alternative is inaccessible simplAlt env handled_cons case_bndr' (DEFAULT, bndrs, rhs) cont' = ASSERT( null bndrs ) simplExprC env' rhs cont' `thenSmpl` \ rhs' -> - returnSmpl (Nothing, (DEFAULT, [], rhs')) + returnSmpl (Just (emptyVarEnv, (DEFAULT, [], rhs'))) where env' = mk_rhs_env env case_bndr' (mkOtherCon handled_cons) -- Record the constructors that the case-binder *can't* be. @@ -1488,7 +1462,7 @@ simplAlt env handled_cons case_bndr' (DEFAULT, bndrs, rhs) cont' simplAlt env handled_cons case_bndr' (LitAlt lit, bndrs, rhs) cont' = ASSERT( null bndrs ) simplExprC env' rhs cont' `thenSmpl` \ rhs' -> - returnSmpl (Nothing, (LitAlt lit, [], rhs')) + returnSmpl (Just (emptyVarEnv, (LitAlt lit, [], rhs'))) where env' = mk_rhs_env env case_bndr' (mkUnfolding False (Lit lit)) @@ -1509,22 +1483,26 @@ simplAlt env handled_cons case_bndr' (DataAlt con, vs, rhs) cont' env' = mk_rhs_env env case_bndr' unf in simplExprC env' rhs cont' `thenSmpl` \ rhs' -> - returnSmpl (Nothing, (DataAlt con, vs', rhs')) + returnSmpl (Just (emptyVarEnv, (DataAlt con, vs', rhs'))) | otherwise -- GADT case = let (tvs,ids) = span isTyVar vs in simplBinders env tvs `thenSmpl` \ (env1, tvs') -> - case coreRefineTys (getInScope env1) con tvs' (idType case_bndr') of { - Nothing -- Dead code; for now, I'm just going to put in an - -- error case so I can see them + case coreRefineTys con tvs' (idType case_bndr') of { + Nothing -- Inaccessible + | opt_PprStyle_Debug -- Hack: if debugging is on, generate an error case + -- so we can see it -> let rhs' = mkApps (Var eRROR_ID) [Type (substTy env (exprType rhs)), Lit (mkStringLit "Impossible alternative (GADT)")] in simplBinders env1 ids `thenSmpl` \ (env2, ids') -> - returnSmpl (Nothing, (DataAlt con, tvs' ++ ids', rhs')) ; + returnSmpl (Just (emptyVarEnv, (DataAlt con, tvs' ++ ids', rhs'))) + + | otherwise -- Filter out the inaccessible branch + -> return Nothing ; Just refine@(tv_subst_env, _) -> -- The normal case @@ -1543,7 +1521,7 @@ simplAlt env handled_cons case_bndr' (DataAlt con, vs, rhs) cont' vs' = tvs' ++ ids' in simplExprC env_w_unf rhs cont' `thenSmpl` \ rhs' -> - returnSmpl (Just tv_subst_env, (DataAlt con, vs', rhs')) } + returnSmpl (Just (tv_subst_env, (DataAlt con, vs', rhs'))) } where -- add_evals records the evaluated-ness of the bound variables of @@ -1740,7 +1718,6 @@ mkDupableCont env (ApplyTo _ arg se cont) -- This has been this way for a long time, so I'll leave it, -- but I can't convince myself that it's right. --- gaw 2004 mkDupableCont env (Select _ case_bndr alts se cont) = -- e.g. (case [...hole...] of { pi -> ei }) -- ===> @@ -1779,17 +1756,24 @@ mkDupableAlts env case_bndr' alts dupable_cont where go env [] = returnSmpl (emptyFloats env, []) go env (alt:alts) - = mkDupableAlt env case_bndr' dupable_cont alt `thenSmpl` \ (floats1, alt') -> - addFloats env floats1 $ \ env -> - go env alts `thenSmpl` \ (floats2, alts') -> - returnSmpl (floats2, alt' : alts') + = do { (floats1, mb_alt') <- mkDupableAlt env case_bndr' dupable_cont alt + ; addFloats env floats1 $ \ env -> do + { (floats2, alts') <- go env alts + ; returnSmpl (floats2, case mb_alt' of + Just alt' -> alt' : alts' + Nothing -> alts' + )}} mkDupableAlt env case_bndr' cont alt - = simplAlt env [] case_bndr' alt cont `thenSmpl` \ (mb_reft, (con, bndrs', rhs')) -> + = simplAlt env [] case_bndr' alt cont `thenSmpl` \ mb_stuff -> + case mb_stuff of { + Nothing -> returnSmpl (emptyFloats env, Nothing) ; + + Just (reft, (con, bndrs', rhs')) -> -- Safe to say that there are no handled-cons for the DEFAULT case if exprIsDupable rhs' then - returnSmpl (emptyFloats env, (con, bndrs', rhs')) + returnSmpl (emptyFloats env, Just (con, bndrs', rhs')) -- It is worth checking for a small RHS because otherwise we -- get extra let bindings that may cause an extra iteration of the simplifier to -- inline back in place. Quite often the rhs is just a variable or constructor. @@ -1811,13 +1795,11 @@ mkDupableAlt env case_bndr' cont alt rhs_ty' = exprType rhs' used_bndrs' = filter abstract_over (case_bndr' : bndrs') abstract_over bndr - | isTyVar bndr = not (mb_reft `refines` bndr) + | isTyVar bndr = not (bndr `elemVarEnv` reft) -- Don't abstract over tyvar binders which are refined away + -- See Note [Refinement] below | otherwise = not (isDeadBinder bndr) -- The deadness info on the new Ids is preserved by simplBinders - refines Nothing bndr = False - refines (Just tv_subst) bndr = bndr `elemVarEnv` tv_subst - -- See Note [Refinement] below in -- If we try to lift a primitive-typed something out -- for let-binding-purposes, we will *caseify* it (!), @@ -1859,7 +1841,7 @@ mkDupableAlt env case_bndr' cont alt ) `thenSmpl` \ (final_bndrs', final_args) -> -- See comment about "$j" name above - newId (encodeFS FSLIT("$j")) (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr -> + newId FSLIT("$j") (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr -> -- Notice the funky mkPiTypes. If the contructor has existentials -- it's possible that the join point will be abstracted over -- type varaibles as well as term variables. @@ -1885,7 +1867,7 @@ mkDupableAlt env case_bndr' cont alt join_rhs = mkLams really_final_bndrs rhs' join_call = mkApps (Var join_bndr) final_args in - returnSmpl (unitFloat env join_bndr join_rhs, (con, bndrs', join_call)) + returnSmpl (unitFloat env join_bndr join_rhs, Just (con, bndrs', join_call)) } \end{code} Note [Refinement]