Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/de8500160c7c019ce0531aa17dbdafac7d13d334 >--------------------------------------------------------------- commit de8500160c7c019ce0531aa17dbdafac7d13d334 Author: Max Bolingbroke <batterseapo...@hotmail.com> 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) _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
