Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/bfde2ee0623a00dd0ea5378f863f6b6bd8fa6bbd >--------------------------------------------------------------- commit bfde2ee0623a00dd0ea5378f863f6b6bd8fa6bbd Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Mon Aug 1 14:56:31 2011 +0100 More cleanups in the evaluator, fix a bug where too many deeds would be released for cast application >--------------------------------------------------------------- .../Supercompile/Evaluator/Evaluate.hs | 18 ++++++++---------- .../supercompile/Supercompile/Evaluator/Syntax.hs | 2 +- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs index a3eef29..ddc1c32 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs @@ -187,13 +187,13 @@ step' normalising state = | otherwise = Just (dereference h a) tyApply :: Deeds -> Heap -> Stack -> Answer -> Out Type -> Maybe UnnormalisedState - tyApply deeds h k a@(_, (_, v)) ty' = do + tyApply deeds h k a ty' = do (mb_co, (rn, TyLambda x e_body)) <- deferenceLambdaish h a fmap (\deeds -> (deeds, h, case mb_co of Nothing -> k; Just (co', tg_co) -> Tagged tg_co (CastIt (co' `mkInstCo` ty')) : k, (insertTypeSubst rn x ty', e_body))) $ claimDeeds (deeds + answerSize' a) (annedSize e_body) coApply :: Deeds -> Heap -> Stack -> Answer -> Out Coercion -> Maybe UnnormalisedState - coApply deeds h k a@(_, (_, v)) apply_co' = do + coApply deeds h k a apply_co' = do (mb_co, (rn, Lambda x e_body)) <- deferenceLambdaish h a flip fmap (claimDeeds (deeds + answerSize' a) (annedSize e_body)) $ \deeds -> case mb_co of Nothing -> (deeds, h, k, (insertCoercionSubst rn x apply_co', e_body)) @@ -208,20 +208,20 @@ step' normalising state = cast_apply_co' = arg_from_co' `mkTransCo` apply_co' `mkTransCo` mkSymCo arg_to_co' apply :: Deeds -> Tag -> Heap -> Stack -> Answer -> Out Var -> Maybe UnnormalisedState - apply deeds tg_v (Heap h ids) k a@(_, (_, v)) x' = do + apply deeds tg_v (Heap h ids) k a x' = do (mb_co, (rn, Lambda x e_body)) <- deferenceLambdaish (Heap h ids) a case mb_co of Nothing -> fmap (\deeds -> (deeds, Heap h ids, k, (insertIdRenaming rn x x', e_body))) $ claimDeeds (deeds + 1 + answerSize' a) (annedSize e_body) Just (co', tg_co) -> fmap (\deeds -> (deeds, Heap (M.insert y' (internallyBound (renamedTerm e_arg)) h) ids', Tagged tg_co (CastIt res_co') : k, (rn', e_body))) $ - claimDeeds (deeds + 1 + answerSize' a) (annedSize e_arg + annedSize e_body) + claimDeeds (deeds + answerSize' a) (annedSize e_arg + annedSize e_body) where (ids', rn', y') = renameNonRecBinder ids rn (x `setIdType` arg_co_from_ty') Pair arg_co_from_ty' _arg_co_to_ty' = coercionKind arg_co' [arg_co', res_co'] = decomposeCo 2 co' e_arg = annedTerm tg_co (annedTerm tg_v (Var x') `Cast` mkSymCo arg_co') scrutinise :: Deeds -> Heap -> Stack -> Tag -> Answer -> Out Var -> Out Type -> In [AnnedAlt] -> Maybe UnnormalisedState - scrutinise deeds0 (Heap h0 ids) k tg_v a@(mb_co_v, (rn_v, v)) wild' _ty' (rn_alts, alts) + scrutinise deeds0 (Heap h0 ids) k tg_v a wild' _ty' (rn_alts, alts) -- Literals are easy -- we can make the simplifying assumption that the types of literals are -- always simple TyCons without any universally quantified type variables. | Literal l <- v_deref @@ -279,13 +279,11 @@ step' normalising state = -- This can legitimately occur, e.g. when supercompiling (if x then (case x of False -> 1) else 2) | otherwise = Nothing - where (mb_co_deref, (rn_v_deref, v_deref)) = dereference (Heap h0 ids) (mb_co_v, (rn_v, v)) + where (mb_co_deref, (rn_v_deref, v_deref)) = dereference (Heap h0 ids) a mb_co_deref_kind = fmap (\(co, tg_co) -> (co, tg_co, coercionKind co)) mb_co_deref (deeds1, h1) | isDeadBinder wild' = (deeds0 + answerSize' a, h0) - | otherwise = (deeds0, M.insert wild' wild_hb h0) - where wild_hb = case mb_co_v of - Nothing -> internallyBound (rn_v, annedTerm tg_v (Value v)) - Just co_tg_v -> internallyBound (renamedTerm $ annedTerm tg_v (castValueToAnnedTerm' co_tg_v (renameAnnedValue' ids rn_v v))) + | otherwise = (deeds0, M.insert wild' wild_hb h0) + where wild_hb = internallyBound $ annedAnswerToInAnnedTerm ids (annedAnswer tg_v a) -- NB: we add the *non-dereferenced* value to the heap for a case wildcard, because anything else may duplicate allocation primop :: Deeds -> Tag -> Heap -> Stack -> Tag -> PrimOp -> [Out Type] -> [Anned Answer] -> Answer -> [In AnnedTerm] -> Maybe UnnormalisedState diff --git a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs index 81d8552..16d2be2 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs @@ -116,7 +116,7 @@ instance Outputable QA where pprPrec prec = pPrintPrec prec . qaToAnnedTerm' emptyInScopeSet annedAnswerToInAnnedTerm :: InScopeSet -> Anned Answer -> In AnnedTerm -annedAnswerToInAnnedTerm iss anned_a = renamedTerm $ annedTerm (annedTag anned_a) $ answerToAnnedTerm' iss (annee anned_a) +annedAnswerToInAnnedTerm iss = renamedTerm . fmap (answerToAnnedTerm' iss) answerToAnnedTerm' :: InScopeSet -> Answer -> TermF Anned answerToAnnedTerm' iss (mb_co, (rn, v)) = maybe Value castValueToAnnedTerm' mb_co $ renameAnnedValue' iss rn v _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
