Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/4cf0709a0680d3b091a03f67588597526259acc1 >--------------------------------------------------------------- commit 4cf0709a0680d3b091a03f67588597526259acc1 Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Thu Mar 15 12:00:42 2012 +0000 In the evaluator, trim stack frames that are unreachable due to bottoming Ids >--------------------------------------------------------------- .../Supercompile/Evaluator/Evaluate.hs | 41 +++++++++++++++++++- .../supercompile/Supercompile/Evaluator/Syntax.hs | 5 ++- compiler/supercompile/Supercompile/Utilities.hs | 6 ++- 3 files changed, 49 insertions(+), 3 deletions(-) diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs index d0e1f71..1eb89bf 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs @@ -17,13 +17,14 @@ import qualified Data.Map as M import qualified CoreSyn as CoreSyn import CoreUnfold (exprIsConApp_maybe) -import Coercion (liftCoSubstWith, coercionKind, isReflCo) +import Coercion (liftCoSubstWith, coercionKind, isReflCo, mkUnsafeCo) import TyCon import Type import PrelRules import Id import DataCon import Pair +import Demand (splitStrictSig, isBotRes) evaluatePrim :: InScopeSet -> Tag -> PrimOp -> [Type] -> [Answer] -> Maybe (Anned Answer) @@ -167,6 +168,13 @@ step' normalising ei_state = {-# SCC "step'" #-} | not (dUPLICATE_VALUES_EVALUATOR && normalising) , Just anned_a <- lookupAnswer (Heap h ids) x' -- NB: don't unwind *immediately* because we want that changing a Var into a Value in an empty stack is seen as a reduction 'step' = do { (deeds, a) <- prepareAnswer deeds x' (annee anned_a); return (deeds, Heap h ids, k, annedAnswerToInAnnedTerm ids $ annedAnswer (annedTag anned_a) a) } + -- Try to trim the stack if the Id is guaranteed to bottom out after a certain number of arguments + -- This is really amazingly important because so many case branches bottom out in at least one branch, + -- and we can save supercompiling big case nests if we trim them out eagerly. + | Just (ds, res_d) <- fmap splitStrictSig $ idStrictness_maybe x' + , isBotRes res_d + , Just (h_extra, k) <- trimUnreachable (length ds) (idType x') k + = Just (deeds, Heap (h `M.union` h_extra) ids, k, renamedTerm (annedTerm tg (Var x'))) | otherwise = do hb <- M.lookup x' h in_e <- heapBindingTerm hb @@ -180,6 +188,37 @@ step' normalising ei_state = {-# SCC "step'" #-} kf `Car` _ | Update y' <- tagee kf -> (deeds, Heap (M.insert x' (internallyBound (mkIdentityRenaming (unitVarSet y'), annedTerm (tag kf) (Var y'))) h) ids, k, in_e) _ -> (deeds, Heap (M.delete x' h) ids, Tagged tg (Update x') `Car` k, in_e) + -- TODO: this function totally ignores deeds + trimUnreachable :: Int -- Number of value arguments needed before evaluation bottoms out + -> Type -- Type of the possibly-bottoming thing in the hole + -> Stack -- Stack consuming the hole + -> Maybe (PureHeap, -- Heap bindings arising from any update frames we trimmed off + Stack) -- Trimmed stack (strictly "less" than the input one -- not necessarily shorter since we will replace e.g. a trailing Scrutinise with a Cast) + trimUnreachable = go + where + -- Ran out of stack: even if n == 0 we don't want to + -- trim the stack in these cases because we musn't return + -- Just if the tail of the stack is already trivial: doing + -- so would risk non-termination + go _ _ (Loco _) = Nothing + go _ _ (Tagged _ (CastIt _) `Car` Loco _) = Nothing + -- Got some non-trivial stack that is unreachable due to bottomness: kill it + go 0 hole_ty k@(Tagged cast_tg _ `Car` _) = Just $ + trainFoldl' (\(!hole_ty, !h) (Tagged tg kf) -> (stackFrameType' kf hole_ty, case kf of Update x' -> M.insert x' (internallyBound (renamedTerm (annedTerm tg (Var x')))) h; _ -> h)) + (\(!overall_ty, !h) gen -> (h, (if hole_ty `eqType` overall_ty then id else (Tagged cast_tg (CastIt (mkUnsafeCo hole_ty overall_ty)) `Car`)) $ Loco gen)) (hole_ty, M.empty) k + -- Haven't yet reached a bottom, but we might get enough arguments to reach + -- one in the future, so keep going + go n hole_ty (kf `Car` k) = mb_n' >>= \n' -> liftM (second (kf `Car`)) $ go n' (stackFrameType kf hole_ty) k + where mb_n' = case tagee kf of + TyApply _ -> Just n + CoApply _ -> Just (n - 1) + Apply _ -> Just (n - 1) + Scrutinise _ _ _ -> Nothing + PrimApply _ _ _ _ -> Nothing + StrictLet _ _ -> Nothing + Update _ -> Just n + CastIt _ -> Just n + -- Deal with a value at the top of the stack unwind :: Deeds -> Heap -> Stack -> Tag -> Answer -> Maybe UnnormalisedState unwind deeds h k tg_v a = unconsTrain k >>= \(kf, k) -> case tagee kf of diff --git a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs index ebaf92e..fba773d 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs @@ -282,7 +282,10 @@ stackType :: Stack -> Type -> Type stackType k ty = trainCarFoldl' (flip stackFrameType) ty k stackFrameType :: Tagged StackFrame -> Type -> Type -stackFrameType kf hole_ty = case tagee kf of +stackFrameType = stackFrameType' . tagee + +stackFrameType' :: StackFrame -> Type -> Type +stackFrameType' kf hole_ty = case kf of TyApply ty -> hole_ty `applyTy` ty CoApply co -> hole_ty `applyFunTy` coercionType co Apply x -> hole_ty `applyFunTy` idType x diff --git a/compiler/supercompile/Supercompile/Utilities.hs b/compiler/supercompile/Supercompile/Utilities.hs index 4ea1b2c..cbefcf0 100644 --- a/compiler/supercompile/Supercompile/Utilities.hs +++ b/compiler/supercompile/Supercompile/Utilities.hs @@ -661,6 +661,10 @@ trainToList :: Train a b -> ([a], b) trainToList (Car a abs) = first (a:) (trainToList abs) trainToList (Loco b) = ([], b) +trainLoco :: Train a b -> b +trainLoco (Car _ abs) = trainLoco abs +trainLoco (Loco b) = b + trainCars :: Train a b -> [a] trainCars (Car a abs) = a : trainCars abs trainCars (Loco _) = [] @@ -669,7 +673,7 @@ trainCarFoldl' :: (c -> a -> c) -> c -> Train a b -> c trainCarFoldl' f_car = trainFoldl' f_car (\s _a -> s) {-# INLINE trainFoldl' #-} -trainFoldl' :: (c -> a -> c) -> (c -> b -> c) -> c -> Train a b -> c +trainFoldl' :: (c -> a -> c) -> (c -> b -> d) -> c -> Train a b -> d trainFoldl' f_car f_loco = go where go s (Loco b) = s `seq` f_loco s b go s (Car a abs) = s `seq` go (f_car s a) abs _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
