[commit: ghc] supercompiler: Checkpoint deeds in splitter (8900089)

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

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/89000899821ac43616eb11792adafeef3883fabd

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

commit 89000899821ac43616eb11792adafeef3883fabd
Author: Max Bolingbroke <[email protected]>
Date:   Wed Oct 31 11:25:36 2012 +0000

    Checkpoint deeds in splitter

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

 compiler/supercompile/Supercompile/Core/Syntax.hs  |    8 +++
 compiler/supercompile/Supercompile/Drive/Split2.hs |   53 +++++++++++++++++--
 .../supercompile/Supercompile/Evaluator/Syntax.hs  |    4 ++
 3 files changed, 59 insertions(+), 6 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Core/Syntax.hs b/compiler/supercompile/Supercompile/Core/Syntax.hs
index 2084c31..73b2087 100644
--- a/compiler/supercompile/Supercompile/Core/Syntax.hs
+++ b/compiler/supercompile/Supercompile/Core/Syntax.hs
@@ -152,6 +152,14 @@ data ValueG term = Literal Literal | Coercion Coercion
                  | Data DataCon [Type] [Coercion] [Id] -- NB: includes universal and existential type arguments, in that order
                                                        -- NB: not a newtype DataCon
 
+instance Traverseable ValueG where
+    traverse f e = case e of
+      Literal l          -> pure $ Literal l
+      Coercion co        -> pure $ Coercion co
+      TyLambda a e       -> fmap (TyLambda a) $ f e
+      Lambda   x e       -> fmap (Lambda   x) $ f e
+      Data dc tys cos xs -> pure $ Data dc tys cos xs
+
 instance Outputable AltCon where
     pprPrec prec altcon = case altcon of
         DataAlt dc as qs xs -> prettyParen (prec >= appPrec) $ ppr dc <+> hsep (map (pPrintBndr CaseBind) as ++ map (pPrintBndr CaseBind) qs ++ map (pPrintBndr CaseBind) xs)
diff --git a/compiler/supercompile/Supercompile/Drive/Split2.hs b/compiler/supercompile/Supercompile/Drive/Split2.hs
index 7a9041b..721eb6a 100644
--- a/compiler/supercompile/Supercompile/Drive/Split2.hs
+++ b/compiler/supercompile/Supercompile/Drive/Split2.hs
@@ -242,12 +242,12 @@ multEntered = M.unionWith (\_ _ -> ManyEntries)
 split :: (Applicative m, Monad m)
       => (State -> m            (Deeds, Out FVedTerm))
       -> State  -> m (ResidTags, Deeds, Out FVedTerm)
-split opt (_deeds, heap, k, qa) = recurse opt $ push (S.singleton FocusContext) (heap, k, QAFocus qa)
+split opt (deeds, heap, k, qa) = recurse opt $ push (S.singleton FocusContext) (deeds, heap, k, QAFocus qa)
 
 instanceSplit :: (Applicative m, Monad m)
               => (State                             -> m            (Deeds, Out FVedTerm))
               -> (Deeds, Heap, Stack, Out FVedTerm) -> m (ResidTags, Deeds, Out FVedTerm)
-instanceSplit opt (_deeds, heap, k, e) = recurse opt $ push (S.singleton FocusContext) (heap, k, OpaqueFocus e)
+instanceSplit opt (deeds, heap, k, e) = recurse opt $ push (S.singleton FocusContext) (deeds, heap, k, OpaqueFocus e)
 
 applyGeneraliser :: Generaliser -> State -> Maybe (S.Set Context)
 applyGeneraliser gen (_deeds, Heap h _, k, qa) = fmap (\(gen_kfs, gen_xs) -> S.fromList $ map StackContext (IS.elems gen_kfs) ++ map HeapContext (varSetElems gen_xs)) $ case gENERALISATION of
@@ -287,7 +287,7 @@ applyGeneraliser gen (_deeds, Heap h _, k, qa) = fmap (\(gen_kfs, gen_xs) -> S.f
 generaliseSplit :: (Applicative m, Monad m)
                 => (State -> m (Deeds, Out FVedTerm))
                 -> Generaliser -> State -> Maybe (m (ResidTags, Deeds, Out FVedTerm))
-generaliseSplit opt gen state@(_deeds, heap, k, qa) = flip fmap (applyGeneraliser gen state) $ \generalised -> recurse opt $ push generalised (heap, k, QAFocus qa)
+generaliseSplit opt gen state@(deeds, heap, k, qa) = flip fmap (applyGeneraliser gen state) $ \generalised -> recurse opt $ push generalised (deeds, heap, k, QAFocus qa)
 
 
 recurse :: (Applicative m, Monad m)
@@ -449,6 +449,23 @@ test11 = \_ -> f () + 1
 -}
 
 
+newtype DeedsA a = DeedsA { unDeedsA :: (Deeds, [Size], State [Deeds] a) }
+
+instance Functor DeedsA where
+    fmap = liftA
+
+instance Applicative DeedsA where
+    pure x = DeedsA (emptyDeeds, [], return x)
+    DeedsA (deeds1, sizes1, mf) <*> DeedsA (deeds2, sizes2, mx) = DeedsA (deeds1 `mappend` deeds, sizes1 ++ sizes2, mf <*> mx)
+
+one :: Deeds -> Size -> DeedsA Deeds
+one deeds sz = DeedsA (deeds, [sz], state $ \(deeds:deedss) -> (deeds, deedss))
+
+runDeedsA :: DeedsA a -> a
+runDeedsA (DeedsA (deeds, sizes, mx)) = x
+  where ([], x) = runState mx (splitDeeds deeds sizes)
+
+
 data PushFocus qa term = QAFocus qa
                        | TermFocus term
                        | OpaqueFocus FVedTerm
@@ -460,12 +477,36 @@ type PushedValue = Tagged (Coerced (ValueG State))
 type PushedQA    = Tagged (QAG (ValueG State))
 type PushedFocus = PushFocus PushedQA State
 
+traversePushedState :: Applicative t => (State -> t State)
+                    -> (PushedHeap, PushedStack, PushedFocus) -> t (PushedHeap, PushedStack, PushedFocus)
+traversePushedState f (heap, stack, focus) = liftA3 (,,) (traversePushedHeap f heap) (traversePushedStack f stack) (traversePushedFocus f focus)
+
+traversePushedHeap :: Applicative t => (State -> t State)
+                   -> PushedHeap -> t PushedHeap
+traversePushedHeap f = traverse traverse_heap_binding
+  where traverse_heap_binding = either (fmap Left . traversePushedValue f) (fmap Right . f)
+
+traversePushedValue :: Applicative t => (State -> t State)
+                    -> PushedValue -> t PushedValue
+traversePushedValue f = traverse (traverse (traverse f))
+
+traversePushedStack :: Applicative t => (State -> t State)
+                    -> PushedStack -> t PushedStack
+traversePushedStack f = traverse (traverse traverse_stack_frame)
+  where traverse_stack_frame
+
+traversePushedFocus :: Applicative t => (State -> t State)
+                    -> PushedFocus -> t PushedFocus
+traversePushedFocus f (QAFocus qa)    = fmap QAFocus $ traverse (traverse (traverse f)) qa
+traversePushedFocus f (TermFocus e)   = fmap TermFocus $ f e
+traversePushedFocus _ (OpaqueFocus e) = OpaqueFocus e
+
 -- FIXME: deal with deeds in here
 push :: S.Set Context
      -> (Heap, Stack, PushFocus (Anned QA) (In AnnedTerm))
-     -> (PushedHeap, PushedStack, PushedFocus)
-push generalised (Heap h ids, k, focus) = -- pprTrace "push" (ppr verts $$ ppr marked)
-                                          (h', k', focus')
+     -> (Deeds, PushedHeap, PushedStack, PushedFocus)
+push generalised (deeds, Heap h ids, k, focus) = -- pprTrace "push" (ppr verts $$ ppr marked)
+                                                 traversePushed (\(deeds, h, k, qa) -> ) (h', k', focus')
   where -- TODO: arguably I should try to get a QA for the thing in the focus. This will help in cases like where we MSG together:
         --  < H | v | >
         -- and:
diff --git a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs
index 2c81a73..8440fe2 100644
--- a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs
+++ b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs
@@ -129,6 +129,10 @@ type Answer = In AnnedValue
 data QAG answer = Question Question
                 | Answer   answer
 
+instance Traversable QAG where
+    traverse _ (Question x) = pure $ Question x
+    traverse f (Answer a)   = fmap Answer (f a)
+
 type QA = QAG Answer
 
 instance Outputable QA where