[commit: ghc] supercompiler: Generalise residualisation code (bc6a883)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/bc6a88327e2721d8ad13d21842b42be44e125178

>---------------------------------------------------------------

commit bc6a88327e2721d8ad13d21842b42be44e125178
Author: Max Bolingbroke <[email protected]>
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 }