Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/3b675a8d2fd888a65955f19458690885e64787ce >--------------------------------------------------------------- commit 3b675a8d2fd888a65955f19458690885e64787ce Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Wed Jul 27 21:57:55 2011 +0100 Eliminate some dodgy const fmaps with traverses >--------------------------------------------------------------- compiler/supercompile/Supercompile/Core/Syntax.hs | 10 ++++++++-- .../supercompile/Supercompile/Drive/Process.hs | 5 +++-- .../supercompile/Supercompile/Evaluator/Syntax.hs | 9 ++++++--- 3 files changed, 17 insertions(+), 7 deletions(-) diff --git a/compiler/supercompile/Supercompile/Core/Syntax.hs b/compiler/supercompile/Supercompile/Core/Syntax.hs index 1cd4e48..b2d22a0 100644 --- a/compiler/supercompile/Supercompile/Core/Syntax.hs +++ b/compiler/supercompile/Supercompile/Core/Syntax.hs @@ -17,6 +17,8 @@ import Type (Type, mkTyVarTy) import Coercion (Coercion, mkReflCo) import PrimOp (PrimOp) +import Data.Traversable (Traversable(traverse)) + data AltCon = DataAlt DataCon [TyVar] [Id] | LiteralAlt Literal | DefaultAlt deriving (Eq, Show) @@ -139,8 +141,12 @@ pPrintPrecApps :: (Outputable a, Outputable b) => Rational -> a -> [b] -> SDoc pPrintPrecApps prec e1 es2 = prettyParen (not (null es2) && prec >= appPrec) $ pPrintPrec opPrec e1 <+> hsep (map (pPrintPrec appPrec) es2) -termToValue :: Copointed ann => ann (TermF ann) -> Maybe (ann (ValueF ann)) -termToValue e = case extract e of Value v -> Just (fmap (const v) e); _ -> Nothing +termToValue :: Traversable ann => ann (TermF ann) -> Maybe (ann (ValueF ann)) +termToValue anned_e = traverse termToValue' anned_e + +termToValue' :: TermF ann -> Maybe (ValueF ann) +termToValue' (Value v) = Just v +termToValue' _ = Nothing termIsValue :: Copointed ann => ann (TermF ann) -> Bool termIsValue = isValue . extract diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs index 64e6764..f542560 100644 --- a/compiler/supercompile/Supercompile/Drive/Process.hs +++ b/compiler/supercompile/Supercompile/Drive/Process.hs @@ -36,6 +36,7 @@ import FastString (mkFastString) import CoreUtils (mkPiTypes) import qualified Data.Foldable as Foldable +import Data.Traversable (Traversable(traverse)) import qualified Data.Map as M import Data.Monoid import Data.Ord @@ -247,9 +248,9 @@ speculate speculated (stats, (deeds, Heap h ids, k, in_e)) = (M.keysSet h, (stat Stop (_old_state, rb) -> (no_change, rb) Continue hist -> case reduce state of (extra_stats, (deeds, Heap h_speculated_ok' ids, [], qa)) - | Answer a <- annee qa + | Just a <- traverse qaToAnswer qa , let h_unspeculated = h_speculated_ok' M.\\ h_speculated_ok - in_e' = annedAnswerToAnnedTerm (mkInScopeSet (annedFreeVars qa)) (fmap (const a) qa) + in_e' = annedAnswerToAnnedTerm (mkInScopeSet (annedFreeVars a)) a -> ((stats `mappend` extra_stats, deeds, M.insert x' (internallyBound in_e') h_speculated_ok, h_speculated_failure, ids), speculateManyMap hist h_unspeculated) _ -> (no_change, speculation_failure) where state = normalise (deeds, Heap h_speculated_ok ids, [], in_e) diff --git a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs index 686bac5..ed39a01 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs @@ -123,6 +123,9 @@ qaToAnnedTerm' :: InScopeSet -> QA -> TermF Anned qaToAnnedTerm' _ (Question x) = Var x qaToAnnedTerm' iss (Answer a) = answerToAnnedTerm' iss a +qaToAnswer :: QA -> Maybe Answer +qaToAnswer qa = case qa of Answer a -> Just a; Question _ -> Nothing + type UnnormalisedState = (Deeds, Heap, Stack, In AnnedTerm) type State = (Deeds, Heap, Stack, Anned QA) @@ -234,9 +237,9 @@ stackFrameType kf hole_ty = case tagee kf of CastIt co -> pSnd (coercionKind co) qaType :: Anned QA -> Type -qaType qa = case annee qa of - Question x' -> idType x' - Answer a -> answerType (fmap (const a) qa) +qaType anned_qa = case traverse (\qa -> case qa of Question x' -> Left (idType x'); Answer a -> Right a) anned_qa of + Left q_ty -> q_ty + Right anned_a -> answerType anned_a answerType :: Anned Answer -> Type answerType a = case annee a of _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
