Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/ffa5c713527084a208ac254b0a7e067170bc68a5 >--------------------------------------------------------------- commit ffa5c713527084a208ac254b0a7e067170bc68a5 Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Wed Jul 27 19:19:52 2011 +0100 Don't lose deeds when the evaluator builds a term from a bare Var >--------------------------------------------------------------- compiler/supercompile/Supercompile/Core/Size.hs | 24 +++++++------------ .../Supercompile/Evaluator/Evaluate.hs | 2 +- .../supercompile/Supercompile/Evaluator/Syntax.hs | 4 --- 3 files changed, 10 insertions(+), 20 deletions(-) diff --git a/compiler/supercompile/Supercompile/Core/Size.hs b/compiler/supercompile/Supercompile/Core/Size.hs index 3b2d050..a2e1ba4 100644 --- a/compiler/supercompile/Supercompile/Core/Size.hs +++ b/compiler/supercompile/Supercompile/Core/Size.hs @@ -19,30 +19,27 @@ type TaggedSizedFVedAlt = AltF (O Tagged (O Sized FVed)) type TaggedSizedFVedValue = ValueF (O Tagged (O Sized FVed)) -(varSize', termSize, termSize', altsSize, valueSize, valueSize') = mkSize (\f (I e) -> f e) -(fvedVarSize', fvedTermSize, fvedTermSize', fvedAltsSize, fvedValueSize, fvedValueSize') = mkSize (\f (FVed _ e) -> f e) -(sizedVarSize', sizedTermSize, sizedTermSize', sizedAltsSize, sizedValueSize, sizedValueSize') = mkSize (\_ (Sized sz _) -> sz) -(sizedFVedVarSize', sizedFVedTermSize, sizedFVedTermSize', sizedFVedAltsSize, sizedFVedValueSize, sizedFVedValueSize') = mkSize (\_ (Comp (Sized sz (FVed _ _))) -> sz) -(taggedSizedFVedVarSize', taggedSizedFVedTermSize, taggedSizedFVedTermSize', taggedSizedFVedAltsSize, taggedSizedFVedValueSize, taggedSizedFVedValueSize') = mkSize (\_ (Comp (Tagged _ (Comp (Sized sz (FVed _ _))))) -> sz) +(termSize, termSize', altsSize, valueSize, valueSize') = mkSize (\f (I e) -> f e) +(fvedTermSize, fvedTermSize', fvedAltsSize, fvedValueSize, fvedValueSize') = mkSize (\f (FVed _ e) -> f e) +(sizedTermSize, sizedTermSize', sizedAltsSize, sizedValueSize, sizedValueSize') = mkSize (\_ (Sized sz _) -> sz) +(sizedFVedTermSize, sizedFVedTermSize', sizedFVedAltsSize, sizedFVedValueSize, sizedFVedValueSize') = mkSize (\_ (Comp (Sized sz (FVed _ _))) -> sz) +(taggedSizedFVedTermSize, taggedSizedFVedTermSize', taggedSizedFVedAltsSize, taggedSizedFVedValueSize, taggedSizedFVedValueSize') = mkSize (\_ (Comp (Tagged _ (Comp (Sized sz (FVed _ _))))) -> sz) {-# INLINE mkSize #-} mkSize :: (forall a. (a -> Size) -> ann a -> Size) - -> (Var -> Size, - ann (TermF ann) -> Size, + -> (ann (TermF ann) -> Size, TermF ann -> Size, [AltF ann] -> Size, ann (ValueF ann) -> Size, ValueF ann -> Size) -mkSize rec = (var', term, term', alternatives, value, value') +mkSize rec = (term, term', alternatives, value, value') where - var' = const 0 - term = rec term' term' e = 1 + case e of - Var x -> var' x + Var _ -> 0 Value v -> value' v - 1 -- Slight hack here so that we don't get +2 size on values TyApp e _ -> term e - App e x -> term e + var' x + App e _ -> term e PrimOp _ _ es -> sum (map term es) Case e _ _ alts -> term e + alternatives alts Let _ e1 e2 -> term e1 + term e2 @@ -74,9 +71,6 @@ instance Symantics (O Sized FVed) where letRec xes = sizedFVedTerm . LetRec xes cast e = sizedFVedTerm . Cast e -sizedFVedVar :: Var -> (O Sized FVed) Var -sizedFVedVar x = Comp (Sized (sizedFVedVarSize' x) (FVed (sizedFVedVarFreeVars' x) x)) - sizedFVedValue :: SizedFVedValue -> (O Sized FVed) SizedFVedValue sizedFVedValue v = Comp (Sized (sizedFVedValueSize' v) (FVed (sizedFVedValueFreeVars' v) v)) diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs index 5583ae3..77c8301 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs @@ -89,7 +89,7 @@ step' normalising state = go (deeds, heap@(Heap h ids), k, (rn, e)) | Just anned_a <- termToAnswer ids (rn, e) = go_answer (deeds, heap, k, anned_a) | otherwise = case annee e of - Var x -> go_question (deeds, heap, k, annedVar (annedTag e) (renameId rn x)) + Var x -> go_question (deeds, heap, k, fmap (\(rn, Var _) -> renameId rn x) (renameAnned (rn, e))) Value v -> pprPanic "step': values are always answers" (ppr v) TyApp e ty -> go (deeds, heap, Tagged tg (TyApply (renameType ids rn ty)) : k, (rn, e)) App e x -> go (deeds, heap, Tagged tg (Apply (renameId rn x)) : k, (rn, e)) diff --git a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs index 515e8ca..686bac5 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs @@ -54,7 +54,6 @@ annedValueFreeVars = taggedSizedFVedValueFreeVars annedValueFreeVars' = taggedSizedFVedValueFreeVars' annedAltsFreeVars = taggedSizedFVedAltsFreeVars -annedVarSize' = taggedSizedFVedVarSize' annedTermSize' = taggedSizedFVedTermSize' annedTermSize = taggedSizedFVedTermSize annedValueSize' = taggedSizedFVedValueSize' @@ -73,9 +72,6 @@ detagAnnedValue' = taggedSizedFVedValue'ToFVedValue' detagAnnedAlts = taggedSizedFVedAltsToFVedAlts -annedVar :: Tag -> Var -> Anned Var -annedVar tg x = Comp (Tagged tg (Comp (Sized (annedVarSize' x) (FVed (annedVarFreeVars' x) x)))) - annedTerm :: Tag -> TermF Anned -> AnnedTerm annedTerm tg e = Comp (Tagged tg (Comp (Sized (annedTermSize' e) (FVed (annedTermFreeVars' e) e)))) _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
