[commit: ghc] supercompiler: Tweak to Evaluate to prevent a cast answer evaluating to itself in one step (triggers reduce-stop). Still needs work. (1849424)

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

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/18494246c697dd70ae4e88d8c50f42b1a737ab71

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

commit 18494246c697dd70ae4e88d8c50f42b1a737ab71
Author: Max Bolingbroke <[email protected]>
Date:   Thu Aug 4 12:03:31 2011 +0100

    Tweak to Evaluate to prevent a cast answer evaluating to itself in one step (triggers reduce-stop). Still needs work.

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

 .../Supercompile/Evaluator/Evaluate.hs             |   31 +++++++++++++-------
 1 files changed, 20 insertions(+), 11 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
index 406b274..16898ab 100644
--- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
+++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
@@ -73,27 +73,36 @@ castAnswer (mb_co, in_v) mb_co' = (plusMaybe (\(co, _tg) (co', tg') -> (co `mkTr
 -- Normalisation only ever releases deeds: it is *never* a net consumer of deeds. So normalisation
 -- will never be impeded by a lack of deeds.
 normalise :: UnnormalisedState -> State
-normalise = snd . step' True
+normalise = snd . step' True . Right
 
 -- | Possibly non-normalising simplification we can only do if we are allowed to by a termination test
 --
 -- Unlike normalisation, stepping may be a net consumer of deeds and thus be impeded by a lack of them.
 step :: State -> Maybe State
 step s = guard reduced >> return result
-  where (reduced, result) = step' False $ denormalise s
-
-step' :: Bool -> UnnormalisedState -> (Bool, State) -- The flag indicates whether we managed to reduce any steps *at all*
-step' normalising state =
-    (\res@(_reduced, stepped_state) -> ASSERT2(noChange (releaseUnnormalisedStateDeed state) (releaseStateDeed stepped_state),
-                                               hang (text "step': deeds lost or gained:") 2 (pPrintFullUnnormalisedState state $$ pPrintFullState stepped_state))
-                                       ASSERT2(subVarSet (stateFreeVars stepped_state) (unnormalisedStateFreeVars state),
-                                               text "step': FVs" $$ hang (text "Before:") 2 (pPrint (unnormalisedStateFreeVars state) $$ pPrintFullUnnormalisedState state) $$
+  where (reduced, result) = step' False $ Left s
+
+step' :: Bool -> Either State UnnormalisedState -> (Bool, State) -- The flag indicates whether we managed to reduce any steps *at all*
+step' normalising ei_state =
+    (\res@(_reduced, stepped_state) -> let _deeds = either releaseStateDeed releaseUnnormalisedStateDeed ei_state
+                                           _doc = either pPrintFullState pPrintFullUnnormalisedState ei_state
+                                           _fvs = either stateFreeVars unnormalisedStateFreeVars ei_state in
+                                       ASSERT2(noChange _deeds (releaseStateDeed stepped_state),
+                                               hang (text "step': deeds lost or gained:") 2 (_doc $$ pPrintFullState stepped_state))
+                                       ASSERT2(subVarSet (stateFreeVars stepped_state) _fvs,
+                                               text "step': FVs" $$ hang (text "Before:") 2 (pPrint _fvs $$ _doc) $$
                                                                     hang (text "After:")  2 (pPrint (stateFreeVars stepped_state) $$ pPrintFullState stepped_state))
                                        -- traceRender (text "normalising" $$ nest 2 (pPrintFullUnnormalisedState state) $$ text "to" $$ nest 2 (pPrintFullState stepped_state)) $
                                        res) $
-    go state
+    go_entry ei_state
   where
-    go :: (Deeds, Heap, Stack, In AnnedTerm) -> (Bool, State)
+    go_entry :: Either State UnnormalisedState -> (Bool, State)
+    go_entry (Left (deeds, heap, k, anned_qa)) = case annee anned_qa of
+      Question x' -> go_question (deeds, heap, k, fmap (\(Question x) -> x) anned_qa)
+      Answer   a  -> go_answer   (deeds, heap, k, fmap (\(Answer a) -> a)   anned_qa)
+    go_entry (Right state) = go state
+
+    go :: UnnormalisedState -> (Bool, State)
     go (deeds, heap@(Heap h ids), k, (rn, e)) 
      | Just anned_a <- termToAnswer ids (rn, e) = go_answer (deeds, heap, k, anned_a)
      | otherwise = case annee e of