[commit: ghc] : In the evaluator, trim stack frames that are unreachable due to bottoming Ids (4cf0709)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/4cf0709a0680d3b091a03f67588597526259acc1

>---------------------------------------------------------------

commit 4cf0709a0680d3b091a03f67588597526259acc1
Author: Max Bolingbroke <[email protected]>
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