Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/ddde588cd09e6a7b43992277299273378b732eea >--------------------------------------------------------------- commit ddde588cd09e6a7b43992277299273378b732eea Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Wed Mar 14 22:24:04 2012 +0000 Fix small bug in speculation and add multiple comments >--------------------------------------------------------------- .../supercompile/Supercompile/Core/FreeVars.hs | 7 ++++- .../supercompile/Supercompile/Drive/Process.hs | 26 +++++++++++++++++-- .../supercompile/Supercompile/Evaluator/Syntax.hs | 2 +- 3 files changed, 29 insertions(+), 6 deletions(-) diff --git a/compiler/supercompile/Supercompile/Core/FreeVars.hs b/compiler/supercompile/Supercompile/Core/FreeVars.hs index f3813b5..51776aa 100644 --- a/compiler/supercompile/Supercompile/Core/FreeVars.hs +++ b/compiler/supercompile/Supercompile/Core/FreeVars.hs @@ -88,8 +88,11 @@ altConFreeVars DefaultAlt = id coercedFreeVars :: (a -> FreeVars) -> Coerced a -> FreeVars -coercedFreeVars f (Uncast, x) = f x -coercedFreeVars f (CastBy co _, x) = f x `unionVarSet` tyCoVarsOfCo co +coercedFreeVars f (cast_by, x) = f x `unionVarSet` castByFreeVars cast_by + +castByFreeVars :: CastBy -> FreeVars +castByFreeVars Uncast = emptyVarSet +castByFreeVars (CastBy co _) = tyCoVarsOfCo co data FVed a = FVed { freeVars :: !FreeVars, fvee :: !a } diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs index e0b06f7..8fb9b70 100644 --- a/compiler/supercompile/Supercompile/Drive/Process.hs +++ b/compiler/supercompile/Supercompile/Drive/Process.hs @@ -656,10 +656,30 @@ speculateHeap speculated (stats, deeds, Heap h ids) = {-# SCC "speculate" #-} (M -> spec_trace "speculation denied" (ppr x' {- $$ pPrintFullState quietStatePrettiness (gc state) $$ pPrintFullState quietStatePrettiness _gced_old_state -}) (no_change, {- speculation_failure Nothing -} if any (`isSuffixOf` old_parents') forbidden then speculation_failure Nothing else rb) -- Don't allow rollback to rolled back region Continue hist -> case reduceWithStats state of - (extra_stats, (deeds, Heap h_speculated_ok' ids, Loco _, qa)) - | Just a <- traverse qaToAnswer qa + (extra_stats, (deeds, Heap h_speculated_ok' ids, k, qa)) + -- I used to insist that evaluation should reach an *answer*, but actually it's really good if we + -- get any cheap thing -- so questions are OK, and even cast questions are permissible (cast answers + -- will never occur in practice). + -- + -- A case where this makes a difference is if we have: + -- (+)_selector $dNumInteger + -- It will normally get speculated to a Question: + -- GHC.Integer.plusInteger + -- Due to the fact that plusInteger does not have an unfolding. + -- + -- If the speculator only keeps Answers then it wouldn't keep this result, + -- and thus if we had something like: + -- (let add = (+)_selector $dNumInteger in (.. add .., .. add ..)) + -- Then we got a residual let-binding for "add", and the two h-functions + -- corresponding to each component of the tuple were lambda-abstracted + -- over "add"! + | Just cast_by <- stackToCast k , let h_unspeculated = h_speculated_ok' M.\\ h_speculated_ok - in_e' = annedAnswerToInAnnedTerm (mkInScopeSet (annedFreeVars a)) a + -- NB: this "fmap" is safe for a rather delicate reason -- the renaming returned by annedQAToInAnnedTerm + -- is an identity renaming that includes at least all of the variables in the input InScopeSet, *IN THE CASE + -- THAT YOU PASS AN ANSWER*. This is just barely sufficient for our purposes due to the fact that "reduce" never + -- returns an Answer with a cast pending on the stack -- it only returns such a Question. + in_e' = fmap (castAnnedTerm cast_by) $ annedQAToInAnnedTerm (mkInScopeSet (castByFreeVars cast_by `unionVarSet` annedFreeVars qa)) qa -> (((hist, forbidden, ids), (stats `mappend` extra_stats, deeds, M.insert x' (internallyBound in_e') h_speculated_ok, h_speculated_failure)), speculateManyMap parents' h_unspeculated) _ -> (no_change, speculation_failure Nothing) where state = normalise (deeds, Heap h_speculated_ok ids, Loco False, in_e) diff --git a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs index a19d953..ebaf92e 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs @@ -144,7 +144,7 @@ annedQuestionToInAnnedTerm iss anned_q = (mkInScopeIdentityRenaming iss, fmap Va annedAnswerToInAnnedTerm :: InScopeSet -> Anned Answer -> In AnnedTerm annedAnswerToInAnnedTerm iss anned_a = case annee anned_a of (Uncast, (rn, v)) -> (rn, fmap Value $ annedValue (annedTag anned_a) v) - (CastBy co co_tg, (rn, v)) -> (mkInScopeIdentityRenaming iss, annedTerm (annedTag anned_a) $ Cast (fmap Value $ annedValue co_tg $ renameAnnedValue' iss rn v) co) + (CastBy co co_tg, (rn, v)) -> (mkInScopeIdentityRenaming iss, annedTerm (annedTag anned_a) $ Cast (fmap Value $ annedValue co_tg $ renameAnnedValue' iss rn v) co) answerToAnnedTerm' :: InScopeSet -> Answer -> TermF Anned answerToAnnedTerm' iss (mb_co, (rn, v)) = case mb_co of _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
