X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FsimplCore%2FFloatIn.lhs;h=6a05a98bb4fe4860ad0ce5090b5aece388f9ba2d;hb=99b85ea1e23d32f912e8a8339f83712f1a7b5d49;hp=52250b4dbaa8a29ac5882c33699f107be676f8b2;hpb=111cee3f1ad93816cb828e38b38521d85c3bcebb;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index 52250b4..6a05a98 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -16,16 +16,16 @@ module FloatIn ( floatInwards ) where #include "HsVersions.h" -import CmdLineOpts ( opt_D_verbose_core2core ) +import CmdLineOpts ( DynFlags, DynFlag(..) ) import CoreSyn import CoreUtils ( exprIsValue, exprIsDupable ) -import CoreLint ( beginPass, endPass ) +import CoreLint ( showPass, endPass ) import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf ) import Id ( isOneShotLambda ) -import Var ( Id, idType, isTyVar ) +import Var ( Id, idType ) import Type ( isUnLiftedType ) import VarSet -import Util ( zipEqual, zipWithEqual ) +import Util ( zipEqual, zipWithEqual, count ) import Outputable \end{code} @@ -33,15 +33,14 @@ Top-level interface function, @floatInwards@. Note that we do not actually float any bindings downwards from the top-level. \begin{code} -floatInwards :: [CoreBind] -> IO [CoreBind] +floatInwards :: DynFlags -> [CoreBind] -> IO [CoreBind] -floatInwards binds +floatInwards dflags binds = do { - beginPass "Float inwards"; + showPass dflags "Float inwards"; let { binds' = map fi_top_bind binds }; - endPass "Float inwards" - opt_D_verbose_core2core {- no specific flag for dumping float-in -} - binds' + endPass dflags "Float inwards" Opt_D_verbose_core2core binds' + {- no specific flag for dumping float-in -} } where @@ -180,16 +179,23 @@ So we treat lambda in groups, using the following rule: Otherwise drop all the bindings outside the group. \begin{code} -fiExpr to_drop (_, AnnLam b body) - = case collect [b] body of - (bndrs, real_body) - | all is_ok bndrs -> mkLams bndrs (fiExpr to_drop real_body) - | otherwise -> mkCoLets' to_drop (mkLams bndrs (fiExpr [] real_body)) - where - collect bs (_, AnnLam b body) = collect (b:bs) body - collect bs body = (reverse bs, body) + -- Hack alert! We only float in through one-shot lambdas, + -- not (as you might guess) through big lambdas. + -- Reason: we float *out* past big lambdas (see the test in the Lam + -- case of FloatOut.floatExpr) and we don't want to float straight + -- back in again. + -- + -- It *is* important to float into one-shot lambdas, however; + -- see the remarks with noFloatIntoRhs. +fiExpr to_drop lam@(_, AnnLam _ _) + | all is_one_shot bndrs -- Float in + = mkLams bndrs (fiExpr to_drop body) + + | otherwise -- Dump it all here + = mkCoLets' to_drop (mkLams bndrs (fiExpr [] body)) - is_ok bndr = isTyVar bndr || isOneShotLambda bndr + where + (bndrs, body) = collectAnnBndrs lam \end{code} We don't float lets inwards past an SCC. @@ -214,11 +220,6 @@ fiExpr to_drop (_, AnnNote InlineMe expr) fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr) = -- Just float in past coercion Note note (fiExpr to_drop expr) - -fiExpr to_drop (_, AnnNote note@(TermUsg _) expr) - = -- Float in past term usage annotation - -- (for now; not sure if this is correct: KSW 1999-05) - Note note (fiExpr to_drop expr) \end{code} For @Lets@, the possible ``drop points'' for the \tr{to_drop} @@ -269,7 +270,7 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) fiExpr to_drop (_,AnnLet (AnnRec bindings) body) = fiExpr new_to_drop body where - (binders, rhss) = unzip bindings + rhss = map snd bindings rhss_fvs = map freeVarsOf rhss body_fvs = freeVarsOf body @@ -341,7 +342,7 @@ fiExpr to_drop (_, AnnCase scrut case_bndr alts) fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs) noFloatIntoRhs (AnnNote InlineMe _) = True -noFloatIntoRhs (AnnLam b _) = not (isId b && isOneShotLambda b) +noFloatIntoRhs (AnnLam b _) = not (is_one_shot b) -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top. -- This makes a big difference for things like -- f x# = let x = I# x# @@ -351,7 +352,9 @@ noFloatIntoRhs (AnnLam b _) = not (isId b && isOneShotLambda b) -- boxing constructor into it, else we box it every time which is very bad -- news indeed. -noFloatIntoRhs rhs = exprIsValue (deAnnotate' rhs) -- We'd just float rigt back out again... +noFloatIntoRhs rhs = exprIsValue (deAnnotate' rhs) -- We'd just float right back out again... + +is_one_shot b = isId b && isOneShotLambda b \end{code} @@ -426,7 +429,7 @@ sepBindsByDropPoint is_case drop_pts floaters -- E -> ...not mentioning x... n_alts = length used_in_flags - n_used_alts = length [() | True <- used_in_flags] + n_used_alts = count id used_in_flags -- returns number of Trues in list. can_push = n_used_alts == 1 -- Used in just one branch || (is_case && -- We are looking at case alternatives