Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/ec2f7fc095ab0543546d85f47a58e004f4fdd891 >--------------------------------------------------------------- commit ec2f7fc095ab0543546d85f47a58e004f4fdd891 Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Thu Mar 22 12:33:51 2012 +0000 Collect reasons as to why unfoldings couldn't be used, experimentally allow non-loopbreaker inlinings >--------------------------------------------------------------- compiler/supercompile/Supercompile.hs | 54 ++++++++++++++-------- compiler/supercompile/Supercompile/Utilities.hs | 5 ++ 2 files changed, 39 insertions(+), 20 deletions(-) diff --git a/compiler/supercompile/Supercompile.hs b/compiler/supercompile/Supercompile.hs index 4acdc36..d88e3e5 100644 --- a/compiler/supercompile/Supercompile.hs +++ b/compiler/supercompile/Supercompile.hs @@ -25,7 +25,7 @@ import qualified Supercompile.Drive.Process1 as S () import qualified Supercompile.Drive.Process2 as S () import qualified Supercompile.Drive.Process3 as S -import BasicTypes (InlinePragma(..), InlineSpec(..), isActiveIn, TupleSort(..)) +import BasicTypes (InlinePragma(..), InlineSpec(..), isActiveIn, TupleSort(..), isStrongLoopBreaker) import CoreSyn import CoreFVs (exprFreeVars) import CoreUtils (exprType) @@ -144,27 +144,32 @@ mkLiftedTupleSelector xs want_x tup_e where n = length xs termUnfoldings :: S.Term -> [(Var, S.Term)] -termUnfoldings e = go (S.termFreeVars e) emptyVarSet [] +termUnfoldings e = go (S.termFreeVars e) emptyVarSet [] [] where - go new_fvs all_fvs all_xes - | isEmptyVarSet added_fvs = all_xes -- FIXME: varBndrFreeVars? - | otherwise = go (unionVarSets (map (S.termFreeVars . snd) added_xes)) (all_fvs `unionVarSet` added_fvs) (added_xes ++ all_xes) + -- FIXME: varBndrFreeVars? + go new_fvs all_fvs all_xwhy_nots all_xes + | isEmptyVarSet added_fvs = pprTrace "termUnfoldings" (vcat [hang (text why_not <> text ":") 2 (vcat (map ppr xs)) | (why_not, xs) <- groups snd fst all_xwhy_nots]) $ + all_xes + | otherwise = go (unionVarSets (map (S.termFreeVars . snd) added_xes)) (all_fvs `unionVarSet` added_fvs) + (added_xwhy_nots ++ all_xwhy_nots) (added_xes ++ all_xes) where added_fvs = new_fvs `minusVarSet` all_fvs - added_xes = [ (x, e) - | x <- varSetElems added_fvs - , Just e <- [varUnfolding x]] + (added_xwhy_nots, added_xes) + = foldVarSet (\x (xwhy_nots, xes) -> case varUnfolding x of + Left why_not -> ((x, why_not):xwhy_nots, xes) + Right e -> ( xwhy_nots, (x, e):xes)) + ([], []) added_fvs varUnfolding x - | Just pop <- isPrimOpId_maybe x = Just $ primOpUnfolding pop - | Just dc <- isDataConWorkId_maybe x = Just $ dataUnfolding dc - | not (shouldExposeUnfolding x) = Nothing - | otherwise = case realIdUnfolding x of - NoUnfolding -> Nothing - OtherCon _ -> Nothing - DFunUnfolding _ dc es -> Just $ runParseM us2 $ coreExprToTerm $ mkLams as $ mkLams xs $ Var (dataConWorkId dc) `mkTyApps` cls_tys `mkApps` [(e `mkTyApps` map mkTyVarTy as) `mkVarApps` xs | e <- es] + | Just pop <- isPrimOpId_maybe x = Right $ primOpUnfolding pop + | Just dc <- isDataConWorkId_maybe x = Right $ dataUnfolding dc + | Just why_not <- shouldExposeUnfolding x = Left why_not + | otherwise = case realIdUnfolding x of + NoUnfolding -> Left "no unfolding" + OtherCon _ -> Left "no positive unfolding" + DFunUnfolding _ dc es -> Right $ runParseM us2 $ coreExprToTerm $ mkLams as $ mkLams xs $ Var (dataConWorkId dc) `mkTyApps` cls_tys `mkApps` [(e `mkTyApps` map mkTyVarTy as) `mkVarApps` xs | e <- es] where (as, theta, _cls, cls_tys) = tcSplitDFunTy (idType x) xs = zipWith (mkSysLocal (fsLit "x")) bv_uniques theta - CoreUnfolding { uf_tmpl = e } -> Just $ runParseM us2 $ coreExprToTerm e + CoreUnfolding { uf_tmpl = e } -> Right $ runParseM us2 $ coreExprToTerm e -- NB: it's OK if the unfolding is a non-value, as the evaluator won't inline LetBound non-values -- We don't want to expose an unfolding if it would not be inlineable in the initial phase. @@ -176,11 +181,20 @@ termUnfoldings e = go (S.termFreeVars e) emptyVarSet [] -- * Exhaustively specialises *locally defined* functions on their dictionary arguments -- * Specialises those *imported* functions that are marked Inlineable shouldExposeUnfolding x = case inl_inline inl_prag of - Inline -> not sUPERINLINABLE_ONLY - Inlinable super -> not sUPERINLINABLE_ONLY || super - NoInline -> not sUPERINLINABLE_ONLY && isActiveIn 2 (inl_act inl_prag) - EmptyInlineSpec -> not sUPERINLINABLE_ONLY + Inlinable super + | only_if_superinlinable, not super -> Just "INLINEABLE but not SUPERINLINABLE" + NoInline + | isActiveIn 2 (inl_act inl_prag) -> Just "NONLINE" + | only_if_superinlinable -> Just "(inactive) NOINLINE, not SUPERINLINABLE" + EmptyInlineSpec + | only_if_superinlinable -> Just "not SUPERINLINABLE" + _ -> Nothing where inl_prag = idInlinePragma x + -- EXPERIMENT: only respect the SUPERINLINABLE distinction on *loop breakers* + -- The motivation is that we don't really want to go around annotating (GHC.Base.>>=), + -- bindIO, etc etc as SUPERINLINABLE. + only_if_superinlinable | sUPERINLINABLE_ONLY = isStrongLoopBreaker (idOccInfo x) + | otherwise = False primOpUnfolding pop = S.tyLambdas as $ S.lambdas xs $ S.primOp pop (map mkTyVarTy as) (map S.var xs) where (as, arg_tys, _res_ty, _arity, _strictness) = primOpSig pop diff --git a/compiler/supercompile/Supercompile/Utilities.hs b/compiler/supercompile/Supercompile/Utilities.hs index ddd3a7f..b1f0976 100644 --- a/compiler/supercompile/Supercompile/Utilities.hs +++ b/compiler/supercompile/Supercompile/Utilities.hs @@ -486,6 +486,11 @@ sumMap f = Foldable.foldr (\x n -> f x + n) 0 sumMapMonoid :: (Foldable f, Monoid b) => (a -> b) -> f a -> b sumMapMonoid f = Foldable.foldr (\x n -> f x `mappend` n) mempty +{-# INLINE groups #-} +groups :: Ord b => (a -> b) -> (a -> c) -> [a] -> [(b, [c])] +groups f g xs = runs f g (sortBy (comparing f) xs) + +{-# INLINE runs #-} runs :: Eq b => (a -> b) -> (a -> c) -> [a] -> [(b, [c])] runs _ _ [] = [] runs f g (x:xs) = go (f x) [g x] xs _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
