[commit: ghc] supercompiler: Push normalisation in (in the evaluator) in preparation for speculative inlining experiment (fdc77e4)

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

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/fdc77e416fe3b3b3a245951bd0138d0feb45310b

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

commit fdc77e416fe3b3b3a245951bd0138d0feb45310b
Author: Max Bolingbroke <[email protected]>
Date:   Thu Mar 22 15:08:22 2012 +0000

    Push normalisation in (in the evaluator) in preparation for speculative inlining experiment

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

 .../Supercompile/Evaluator/Evaluate.hs             |   16 ++++++++--------
 1 files changed, 8 insertions(+), 8 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
index d0e3846..7763ed6 100644
--- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
+++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
@@ -139,8 +139,8 @@ step' normalising ei_state = {-# SCC "step'" #-}
     -- TODO: in all the code below, I'm no longer sure whether we preserve deeds or not. In particular, the CastBy cases
     -- are a worry. But since the deeds stuff is probably on the way out I'm not trying to fix it right now.
 
-    go_question (deeds, h, k, anned_x) = maybe (False, (deeds, h, k, fmap Question anned_x)) (\s -> (True, normalise s)) $ force  deeds h k (annedTag anned_x) (annee anned_x)
-    go_answer   (deeds, h, k, anned_a) = maybe (False, (deeds, h, k, fmap Answer anned_a))   (\s -> (True, normalise s)) $ unwind deeds h k (annedTag anned_a) (annee anned_a)
+    go_question (deeds, h, k, anned_x) = maybe (False, (deeds, h, k, fmap Question anned_x)) ((,) True) $ force  deeds h k (annedTag anned_x) (annee anned_x)
+    go_answer   (deeds, h, k, anned_a) = maybe (False, (deeds, h, k, fmap Answer anned_a))   ((,) True) $ unwind deeds h k (annedTag anned_a) (annee anned_a)
 
     prepareAnswer :: Deeds
                   -> Out Var -- ^ Name to which the value is bound
@@ -173,12 +173,12 @@ step' normalising ei_state = {-# SCC "step'" #-}
     -- Deal with a variable at the top of the stack
     -- Might have to claim deeds if inlining a non-value non-internally-bound thing here
     -- FIXME: look inside unfoldings
-    force :: Deeds -> Heap -> Stack -> Tag -> Out Var -> Maybe UnnormalisedState
+    force :: Deeds -> Heap -> Stack -> Tag -> Out Var -> Maybe State
     force deeds (Heap h ids) k tg x'
       -- NB: inlining values is non-normalising if dUPLICATE_VALUES_EVALUATOR is on (since doing things the long way would involve executing an update frame)
       | 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) }
+      = do { (deeds, a) <- prepareAnswer deeds x' (annee anned_a); return $ normalise (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.
@@ -187,14 +187,14 @@ step' normalising ei_state = {-# SCC "step'" #-}
       | 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')))
+      = Just (deeds, Heap (h `M.union` h_extra) ids, k, fmap (\(Var x') -> Question x') (annedTerm tg (Var x'))) -- Kind of a hacky way to get an Anned Question!
       | otherwise = do
         (how_bound, in_e) <- lookupHeap h x'
         -- NB: we MUST NOT create update frames for non-concrete bindings!! This has bitten me in the past, and it is seriously confusing. 
         if (how_bound == InternallyBound)
          then return ()
          else trace ("force non-internal: " ++ show x') $ fail "force"
-        return $ case k of
+        return $ normalise $ case k of
              -- Avoid creating consecutive update frames: implements "stack squeezing"
              -- FIXME: squeeze through casts as well?
             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)
@@ -232,8 +232,8 @@ step' normalising ei_state = {-# SCC "step'" #-}
                           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
+    unwind :: Deeds -> Heap -> Stack -> Tag -> Answer -> Maybe State
+    unwind deeds h k tg_v a = unconsTrain k >>= \(kf, k) -> fmap normalise $ case tagee kf of
         TyApply ty'                    -> tyApply    (deeds `releaseDeeds` 1)          h k tg_v a ty'
         CoApply co'                    -> coApply    (deeds `releaseDeeds` 1)          h k tg_v a co'
         Apply x2'                      -> apply      deeds                    (tag kf) h k tg_v a x2'