Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/e4168865dc202aa5e9a3bf2e8a553100759d28fa >--------------------------------------------------------------- commit e4168865dc202aa5e9a3bf2e8a553100759d28fa Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Wed May 11 14:51:59 2011 +0100 More small fixes >--------------------------------------------------------------- .../Supercompile/Evaluator/Evaluate.hs | 16 ++++++++-------- compiler/supercompile/Supercompile/Utilities.hs | 3 +++ 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs index 3cd5341..6c81a87 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs @@ -78,7 +78,7 @@ step' normalising state = where go :: (Deeds, Heap, Stack, In AnnedTerm) -> (Bool, State) go (deeds, h@(Heap _ ids), k, (rn, e)) - | Just anned_a <- termToAnswer iss (rn, e) = go_answer (deeds, h, k, anned_a) + | Just anned_a <- termToAnswer ids (rn, e) = go_answer (deeds, h, k, anned_a) | otherwise = case annee e of Var x -> go_question (deeds, h, k, fmap (const (rename rn x)) e) TyApp e ty -> go (deeds, h, Tagged tg (TyApply (renameType ids rn ty)) : k, (rn, e)) @@ -87,7 +87,7 @@ step' normalising state = Case e x ty alts -> go (deeds, h, Tagged tg (Scrutinise (rename rn x) (renameType ids rn ty) (rn, alts)) : k, (rn, e)) Cast e co -> go (deeds, h, Tagged tg (CastIt (renameType ids rn co)) : k, (rn, e)) LetRec xes e -> go (allocate (deeds + 1) h k (rn, (xes, e))) - _ -> panic "reduced" (text "Impossible expression" $ ppr e) + _ -> panic "reduced" (text "Impossible expression" $$ ppr1 e) where tg = annedTag e go_question (deeds, h, k, anned_x) = maybe (False, (deeds, h, k, fmap Question anned_x)) (\s -> (True, normalise s)) $ force deeds h k (annedTag anned_x) (annee anned_x) @@ -165,14 +165,14 @@ step' normalising state = | otherwise = Just (dereference h a) tyApply :: Deeds -> Heap -> Stack -> Answer -> Out Type -> Maybe UnnormalisedState - tyApply deeds h k in_v@(_, v) ty' = do - (rn, TyLambda x e_body) <- deferenceLambdaish h in_v - fmap (\deeds -> (deeds, h, k, (insertTypeSubst x ty' rn, e_body))) $ claimDeeds (deeds + annedValueSize' v) (annedSize e_body) + tyApply deeds h k in_v@(_, (_, v)) ty' = do + (mb_co, (rn, TyLambda x e_body)) <- deferenceLambdaish h in_v + fmap (\deeds -> (deeds, h, k, (insertTypeSubst rn x ty', e_body))) $ claimDeeds (deeds + annedValueSize' v) (annedSize e_body) -- FIXME: deeds in mb_co? apply :: Deeds -> Heap -> Stack -> Answer -> Out Var -> Maybe UnnormalisedState - apply deeds h k in_v@(_, v) x' = do - (rn, Lambda x e_body) <- deferenceLambdaish h in_v - fmap (\deeds -> (deeds, h, k, (insertRenaming x x' rn, e_body))) $ claimDeeds (deeds + annedValueSize' v) (annedSize e_body) + apply deeds h k in_v@(_, (_, v)) x' = do + (mb_co, (rn, Lambda x e_body)) <- deferenceLambdaish h in_v + fmap (\deeds -> (deeds, h, k, (insertRenaming rn x x', e_body))) $ claimDeeds (deeds + annedValueSize' v) (annedSize e_body) -- FIXME: deeds in mb_co? scrutinise :: Deeds -> Heap -> Stack -> Tag -> Answer -> Out Var -> Out Type -> In [AnnedAlt] -> Maybe UnnormalisedState scrutinise deeds (Heap h ids) k tg_v (rn_v, v) x' ty' (rn_alts, alts) diff --git a/compiler/supercompile/Supercompile/Utilities.hs b/compiler/supercompile/Supercompile/Utilities.hs index dc9f457..786fe76 100644 --- a/compiler/supercompile/Supercompile/Utilities.hs +++ b/compiler/supercompile/Supercompile/Utilities.hs @@ -72,6 +72,9 @@ instance (Ord1 f, Ord a) => Ord (Wrapper1 f a) where class Outputable1 f where pprPrec1 :: Outputable a => Rational -> f a -> SDoc + ppr1 :: Outputable a => f a -> SDoc + ppr1 = pprPrec1 noPrec + instance (Outputable1 f, Outputable a) => Outputable (Wrapper1 f a) where pprPrec prec = pprPrec1 prec . unWrapper1 _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
