Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/bc6a88327e2721d8ad13d21842b42be44e125178 >--------------------------------------------------------------- commit bc6a88327e2721d8ad13d21842b42be44e125178 Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Wed Mar 28 11:23:28 2012 +0100 Generalise residualisation code >--------------------------------------------------------------- .../Supercompile/Evaluator/Residualise.hs | 45 +++++++++++++------- 1 files changed, 30 insertions(+), 15 deletions(-) diff --git a/compiler/supercompile/Supercompile/Evaluator/Residualise.hs b/compiler/supercompile/Supercompile/Evaluator/Residualise.hs index 2e7edd8..3eb3b74 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Residualise.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Residualise.hs @@ -13,6 +13,7 @@ import Supercompile.Evaluator.Syntax import Supercompile.Core.FreeVars import Supercompile.Core.Renaming import Supercompile.Core.Syntax +import Supercompile.Core.Tag import Supercompile.Utilities @@ -24,50 +25,64 @@ import qualified Data.Set as S import Data.Ord -residualiseState :: State -> (Deeds, Out [(Var, PrettyFunction)], Out FVedTerm, Generalised) -residualiseState s = (deeds, floats_static, bindManyMixedLiftedness fvedTermFreeVars floats_nonstatic e, gen) +class Symantics ann => Symantics' ann where + inject :: AnnedTerm -> ann (TermF ann) + fvs :: ann (TermF ann) -> FreeVars + +instance Symantics' Identity where + inject = taggedSizedFVedTermToTerm + fvs = termFreeVars + +instance Symantics' FVed where + inject = detagAnnedTerm + fvs = fvedTermFreeVars + + +{-# SPECIALISE residualiseState :: State -> (Deeds, Out [(Var, PrettyFunction)], Out FVedTerm, Generalised) #-} +residualiseState :: Symantics' ann => State -> (Deeds, Out [(Var, PrettyFunction)], Out (ann (TermF ann)), Generalised) +residualiseState s = (deeds, floats_static, bindManyMixedLiftedness fvs floats_nonstatic e, gen) where (deeds, floats_static, floats_nonstatic, e, gen) = residualiseUnnormalisedState (denormalise s) -residualiseUnnormalisedState :: UnnormalisedState -> (Deeds, Out [(Var, PrettyFunction)], Out [(Var, FVedTerm)], Out FVedTerm, Generalised) +residualiseUnnormalisedState :: Symantics' ann => UnnormalisedState -> (Deeds, Out [(Var, PrettyFunction)], Out [(Var, ann (TermF ann))], Out (ann (TermF ann)), Generalised) residualiseUnnormalisedState (deeds, heap, k, in_e) = (deeds, floats_static, floats_nonstatic, e, gen) where (floats_static, floats_nonstatic, e, gen) = residualiseHeap heap (\ids -> residualiseStack ids k (residualiseTerm ids in_e)) -residualiseAnswer :: InScopeSet -> Answer -> Out FVedTerm -residualiseAnswer ids = fvedTerm . detagAnnedTerm' . answerToAnnedTerm' ids +residualiseAnswer :: Symantics' ann => InScopeSet -> Anned Answer -> Out (ann (TermF ann)) +residualiseAnswer ids = inject . fmap (answerToAnnedTerm' ids) -residualiseTerm :: InScopeSet -> In AnnedTerm -> Out FVedTerm -residualiseTerm ids = detagAnnedTerm . renameIn (renameAnnedTerm ids) +residualiseTerm :: Symantics' ann => InScopeSet -> In AnnedTerm -> Out (ann (TermF ann)) +residualiseTerm ids = inject . renameIn (renameAnnedTerm ids) -residualiseHeap :: Heap -> (InScopeSet -> ((Out [(Var, PrettyFunction)], Out [(Var, FVedTerm)]), Out FVedTerm, Generalised)) -> (Out [(Var, PrettyFunction)], Out [(Var, FVedTerm)], Out FVedTerm, Generalised) +residualiseHeap :: Symantics' ann => Heap -> (InScopeSet -> ((Out [(Var, PrettyFunction)], Out [(Var, ann (TermF ann))]), Out (ann (TermF ann)), Generalised)) -> (Out [(Var, PrettyFunction)], Out [(Var, ann (TermF ann))], Out (ann (TermF ann)), Generalised) residualiseHeap (Heap h ids) resid_body = (floats_static_h ++ floats_static_k, floats_nonstatic_h ++ floats_nonstatic_k, e, gen) where (floats_static_h, floats_nonstatic_h) = residualisePureHeap ids h ((floats_static_k, floats_nonstatic_k), e, gen) = resid_body ids -residualisePureHeap :: InScopeSet -> PureHeap -> (Out [(Var, PrettyFunction)], Out [(Var, FVedTerm)]) +residualisePureHeap :: Symantics' ann => InScopeSet -> PureHeap -> (Out [(Var, PrettyFunction)], Out [(Var, ann (TermF ann))]) residualisePureHeap ids h = partitionEithers [fmapEither ((,) x') ((,) x') (residualiseHeapBinding ids hb) | (x', hb) <- M.toList h] -residualiseHeapBinding :: InScopeSet -> HeapBinding -> Either (Out PrettyFunction) (Out FVedTerm) +residualiseHeapBinding :: Symantics' ann => InScopeSet -> HeapBinding -> Either (Out PrettyFunction) (Out (ann (TermF ann))) residualiseHeapBinding ids (HB InternallyBound (Right in_e)) = Right (residualiseTerm ids in_e) residualiseHeapBinding _ hb = Left (asPrettyFunction hb) -residualiseStack :: InScopeSet -> Stack -> Out FVedTerm -> ((Out [(Var, PrettyFunction)], Out [(Var, FVedTerm)]), Out FVedTerm, Generalised) +residualiseStack :: Symantics' ann => InScopeSet -> Stack -> Out (ann (TermF ann)) -> ((Out [(Var, PrettyFunction)], Out [(Var, ann (TermF ann))]), Out (ann (TermF ann)), Generalised) residualiseStack _ (Loco gen) e_body = (([], []), e_body, gen) residualiseStack ids (Car kf k) e_body = first3 ((static_floats ++) *** (nonstatic_floats ++)) $ residualiseStack ids k e where ((static_floats, nonstatic_floats), e) = residualiseStackFrame ids (tagee kf) e_body -residualiseStackFrame :: InScopeSet -> StackFrame -> Out FVedTerm -> ((Out [(Var, PrettyFunction)], Out [(Var, FVedTerm)]), Out FVedTerm) +residualiseStackFrame :: Symantics' ann => InScopeSet -> StackFrame -> Out (ann (TermF ann)) -> ((Out [(Var, PrettyFunction)], Out [(Var, ann (TermF ann))]), Out (ann (TermF ann))) residualiseStackFrame _ (TyApply ty') e = (([], []), e `tyApp` ty') residualiseStackFrame _ (CoApply co') e = (([], []), e `coApp` co') residualiseStackFrame _ (Apply x2') e1 = (([], []), e1 `app` x2') -residualiseStackFrame ids (Scrutinise x' ty in_alts) e = (([], []), case_ e x' ty (detagAnnedAlts $ renameIn (renameAnnedAlts ids) in_alts)) -residualiseStackFrame ids (PrimApply pop tys' as es') e = (([], []), primOp pop tys' (map (residualiseAnswer ids . annee) as ++ e : map (residualiseTerm ids) es')) +residualiseStackFrame ids (Scrutinise x' ty in_alts) e = (([], []), case_ e x' ty (map (second inject) $ renameIn (renameAnnedAlts ids) in_alts)) +residualiseStackFrame ids (PrimApply pop tys' as es') e = (([], []), primOp pop tys' (map (residualiseAnswer ids) as ++ e : map (residualiseTerm ids) es')) residualiseStackFrame ids (StrictLet x' in_e2) e1 = (([], []), let_ x' e1 (residualiseTerm ids in_e2)) residualiseStackFrame _ (Update x') e = (([], [(x', e)]), var x') residualiseStackFrame _ (CastIt co') e = (([], []), e `cast` co') pPrintHeap :: Heap -> SDoc -pPrintHeap (Heap h ids) = pPrint $ map (first (PrettyDoc . pPrintBndr LetBind)) $ floats_static_h ++ [(x, asPrettyFunction1 e) | (x, e) <- floats_nonstatic_h] +pPrintHeap (Heap h ids) = pPrint $ map (first (PrettyDoc . pPrintBndr LetBind)) $ floats_static_h ++ [(x, asPrettyFunction1 (e :: Term)) | (x, e) <- floats_nonstatic_h] where (floats_static_h, floats_nonstatic_h) = residualisePureHeap ids h data StatePrettiness = SP { includeLams :: Bool, includeStatics :: Bool, excludeBindings :: S.Set Var } _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
