[commit: ghc] supercompiler: Claim steps when reducing, ignore deeds for reduce-matching (de85001)

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

On branch  : supercompiler

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

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

commit de8500160c7c019ce0531aa17dbdafac7d13d334
Author: Max Bolingbroke <[email protected]>
Date:   Fri Dec 2 15:12:37 2011 +0000

    Claim steps when reducing, ignore deeds for reduce-matching

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

 .../supercompile/Supercompile/Drive/Process.hs     |   23 ++++++++++++-------
 .../supercompile/Supercompile/Drive/Process3.hs    |    2 +-
 .../supercompile/Supercompile/Evaluator/Deeds.hs   |    3 ++
 compiler/supercompile/Supercompile/StaticFlags.hs  |    4 +++
 4 files changed, 22 insertions(+), 10 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs
index 951bfed..11b922f 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -299,15 +299,20 @@ reduce' :: State -> (SCStats, State)
 reduce' orig_state = go (mkLinearHistory rEDUCE_WQO) orig_state
   where
     -- NB: it is important that we ensure that reduce is idempotent if we have rollback on. I use this property to improve memoisation.
-    go hist state = -- traceRender ("reduce:step", pPrintFullState state) $
-                    case step state of
-        Nothing -> (mempty, state)
-        Just state' -> case terminate hist state of
-          Continue hist' -> go hist' state'
-          Stop old_state -> pprTrace "reduce-stop" (pPrintFullState False old_state $$ pPrintFullState False state) 
-                            -- let smmrse s@(_, _, _, qa) = pPrintFullState s $$ case annee qa of Question _ -> text "Question"; Answer _ -> text "Answer" in
-                            -- pprPreview2 "reduce-stop" (smmrse old_state) (smmrse state) $
-                            (mempty { stat_reduce_stops = 1 }, if rEDUCE_ROLLBACK then old_state else state') -- TODO: generalise?
+    go hist state
+      = -- traceRender ("reduce:step", pPrintFullState state) $
+        case step state of
+          Just (deeds, heap, k, e)
+           | Just deeds' <- if bOUND_STEPS then claimStep deeds else Just deeds
+           , let state' = (deeds', heap, k, e)
+           -> case terminate hist state of
+            Continue hist' -> go hist' state'
+            Stop old_state -> pprTrace "reduce-stop" (pPrintFullState False old_state $$ pPrintFullState False state) 
+                              -- let smmrse s@(_, _, _, qa) = pPrintFullState s $$ case annee qa of Question _ -> text "Question"; Answer _ -> text "Answer" in
+                              -- pprPreview2 "reduce-stop" (smmrse old_state) (smmrse state) $
+                              (mempty { stat_reduce_stops = 1 }, if rEDUCE_ROLLBACK then old_state else state') -- TODO: generalise?
+          _ -> (mempty, state)
+
 
 
 --
diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs
index e1c1559..07dc19a 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -205,7 +205,7 @@ memo opt state = join $ ScpM $ StateT $ \(ms, hist, fs) ->
                                      ; traceRenderM "<sc" (fun p, PrettyDoc (pPrintFullState False state), res)
                                      ; fulfillM p res }, (ms', hist, fs))
                 where (p, ms') = promise (state, reduced_state) ms
-  where reduced_state = reduce state
+  where reduced_state = reduce (case state of (_, h, k, e) -> (maxBound, h, k, e)) -- Reduce ignoring deeds for better normalisation
 
 supercompile :: M.Map Var Term -> Term -> Term
 supercompile unfoldings e = fVedTermToTerm $ runScpM $ liftM snd $ sc state
diff --git a/compiler/supercompile/Supercompile/Evaluator/Deeds.hs b/compiler/supercompile/Supercompile/Evaluator/Deeds.hs
index 6219502..018785e 100644
--- a/compiler/supercompile/Supercompile/Evaluator/Deeds.hs
+++ b/compiler/supercompile/Supercompile/Evaluator/Deeds.hs
@@ -32,6 +32,9 @@ emptyDeeds = Deeds { sizeLimit = 0, stepLimit = 0 }
 plusDeeds :: Deeds -> Deeds -> Deeds
 plusDeeds d1 d2 = d1 `seq` d2 `seq` Deeds { sizeLimit = sizeLimit d1 + sizeLimit d2, stepLimit = stepLimit d1 + stepLimit d2 }
 
+claimStep :: Deeds -> Maybe Deeds
+claimStep deeds = guard (stepLimit deeds > 0) >> return (deeds { stepLimit = stepLimit deeds - 1 })
+
 -- NB: it is OK if the number of deeds to claim is negative -- that just causes some deeds to be released
 claimDeeds :: Deeds -> Int -> Maybe Deeds
 claimDeeds deeds want = guard (not dEEDS || sizeLimit deeds >= want) >> return (deeds { sizeLimit = sizeLimit deeds - want })
diff --git a/compiler/supercompile/Supercompile/StaticFlags.hs b/compiler/supercompile/Supercompile/StaticFlags.hs
index b37f342..1512921 100644
--- a/compiler/supercompile/Supercompile/StaticFlags.hs
+++ b/compiler/supercompile/Supercompile/StaticFlags.hs
@@ -21,6 +21,10 @@ dEEDS :: Bool
 dEEDS = "--deeds" `elem` aRGS
 --dEEDS = True
 
+bOUND_STEPS :: Bool
+bOUND_STEPS = "--bound-steps" `elem` aRGS
+--bOUND_STEPS = True
+
 data DeedsPolicy = FCFS | Proportional
                  deriving (Read)