[commit: ghc] : MSGing *changes* FVs, so it is invalid to just traverse the Anned constructor. Doh. (355a9c9)

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

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/355a9c976e63b6ea4c4fbd6ed89fb8af6c2e6fbc

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

commit 355a9c976e63b6ea4c4fbd6ed89fb8af6c2e6fbc
Author: Max Bolingbroke <[email protected]>
Date:   Wed Apr 18 23:16:24 2012 +0100

    MSGing *changes* FVs, so it is invalid to just traverse the Anned constructor. Doh.

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

 compiler/supercompile/Supercompile/Drive/MSG.hs    |   18 ++++++++----------
 .../supercompile/Supercompile/Evaluator/Syntax.hs  |    4 ++++
 2 files changed, 12 insertions(+), 10 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs
index 73d30b4..ea23e78 100644
--- a/compiler/supercompile/Supercompile/Drive/MSG.hs
+++ b/compiler/supercompile/Supercompile/Drive/MSG.hs
@@ -86,11 +86,9 @@ instance Monad MSG where
 
 msgFlexiVar :: Var -> Var -> MSG Var
 msgFlexiVar x_l x_r = MSG $ \s -> Right $ case M.lookup (x_l, x_r) (msgKnownFlexiPairs s) of
-  Nothing -> if x == x_r
-             then pprPanic "msgFlexiVar" (ppr (x_l, x_r))
-             else (s { msgInScopeSet = extendInScopeSet (msgInScopeSet s) x,
-                       msgKnownFlexiPairs = M.insert (x_l, x_r) x (msgKnownFlexiPairs s),
-                       msgPending = (x, (x_l, x_r)) : msgPending s }, x)
+  Nothing -> (s { msgInScopeSet = extendInScopeSet (msgInScopeSet s) x,
+                  msgKnownFlexiPairs = M.insert (x_l, x_r) x (msgKnownFlexiPairs s),
+                  msgPending = (x, (x_l, x_r)) : msgPending s }, x)
     where x = uniqAway (msgInScopeSet s) x_r
   Just x  -> (s, x)
 
@@ -157,7 +155,7 @@ msgWithReason {- mm -} (deeds_l, Heap h_l ids_l, k_l, qa_l) (deeds_r, Heap h_r i
                       return ((deeds_l, Heap h_l ids_l, mkRenaming (M.toList rn_l), k_l), (heap, k, qa), (deeds_r, Heap h_r ids_r, mkRenaming (M.toList rn_r), k_r))
                  | mrn2mk <- msgEC init_rn2 k_l k_r
                  , mres <- prod (do (rn2, mk) <- mrn2mk
-                                    (msg_s, res@(_, (k_l, _, k_r))) <- unMSG (liftM2 (,) (msgAnned (msgQA rn2) qa_l qa_r) (mk rn2)) msg_s
+                                    (msg_s, res@(_, (k_l, _, k_r))) <- unMSG (liftM2 (,) (msgAnned annedQA (msgQA rn2) qa_l qa_r) (mk rn2)) msg_s
                                     return (map (liftM ((,) res)) $ msgPureHeap {- mm -} rn2 msg_s h_l h_r (stackOpenFreeVars k_l) (stackOpenFreeVars k_r)))
                  ]
   where
@@ -167,9 +165,9 @@ msgWithReason {- mm -} (deeds_l, Heap h_l ids_l, k_l, qa_l) (deeds_r, Heap h_r i
     --firstSuccess [Left msg] | trace ("firstSuccess: " ++ msg) False = undefined
     firstSuccess (it:_) = it
 
-msgAnned :: (a -> a -> MSG b)
+msgAnned :: (Tag -> b -> Anned b) -> (a -> a -> MSG b)
          -> Anned a -> Anned a -> MSG (Anned b)
-msgAnned f a_l a_r = flip traverse a_r $ f (annee a_l) -- Right biased
+msgAnned anned f a_l a_r = liftM (anned (annedTag a_r)) $ f (annee a_l) (annee a_r) -- Right biased
 
 msgQA :: RnEnv2 -> QA -> QA -> MSG QA
 msgQA rn2 (Question x_l') (Question x_r') = liftM Question $ msgVar rn2 x_l' x_r'
@@ -214,7 +212,7 @@ msgCoercion rn2 (InstCo co_l ty_l)       (InstCo co_r ty_r)       = liftM2 InstC
 msgCoercion _ _ _ = fail "msgCoercion"
 
 msgTerm :: RnEnv2 -> AnnedTerm -> AnnedTerm -> MSG AnnedTerm
-msgTerm rn2 = msgAnned (msgTerm' rn2)
+msgTerm rn2 = msgAnned annedTerm (msgTerm' rn2)
 
 -- TODO: allow lets on only one side? Useful for msging e.g. (let x = 2 in y + x) with (z + 2)
 msgTerm' :: RnEnv2 -> TermF Anned -> TermF Anned -> MSG (TermF Anned)
@@ -437,7 +435,7 @@ msgECFrame init_rn2 kf_l kf_r = liftM (second (liftM (Tagged (tag kf_r)) .)) $ g
     go (Apply x_l')                          (Apply x_r')                          = return (init_rn2, \rn2 -> liftM Apply $ msgVar rn2 x_l' x_r')
     go (TyApply ty_l')                       (TyApply ty_r')                       = return (init_rn2, \rn2 -> liftM TyApply $ msgType rn2 ty_l' ty_r')
     go (Scrutinise x_l' ty_l' in_alts_l)     (Scrutinise x_r' ty_r' in_alts_r)     = return (init_rn2, \rn2 -> liftM2 (\ty (x, in_alts) -> Scrutinise x ty in_alts) (msgType rn2 ty_l' ty_r') (msgIdCoVarBndr (,) rn2 x_l' x_r' $ \rn2 -> msgIn renameAnnedAlts annedAltsFreeVars msgAlts rn2 in_alts_l in_alts_r))
-    go (PrimApply pop_l tys_l' as_l in_es_l) (PrimApply pop_r tys_r' as_r in_es_r) = return (init_rn2, \rn2 -> guard "msgECFrame: primop" (pop_l == pop_r) >> liftM3 (PrimApply pop_r) (zipWithEqualM (msgType rn2) tys_l' tys_r') (zipWithEqualM (msgAnned (msgAnswer rn2)) as_l as_r) (zipWithEqualM (msgIn renameAnnedTerm annedTermFreeVars msgTerm rn2) in_es_l in_es_r))
+    go (PrimApply pop_l tys_l' as_l in_es_l) (PrimApply pop_r tys_r' as_r in_es_r) = return (init_rn2, \rn2 -> guard "msgECFrame: primop" (pop_l == pop_r) >> liftM3 (PrimApply pop_r) (zipWithEqualM (msgType rn2) tys_l' tys_r') (zipWithEqualM (msgAnned annedAnswer (msgAnswer rn2)) as_l as_r) (zipWithEqualM (msgIn renameAnnedTerm annedTermFreeVars msgTerm rn2) in_es_l in_es_r))
     go (StrictLet x_l' in_e_l)               (StrictLet x_r' in_e_r)               = return (init_rn2, \rn2 -> msgIdCoVarBndr StrictLet rn2 x_l' x_r' $ \rn2 -> msgIn renameAnnedTerm annedTermFreeVars msgTerm rn2 in_e_l in_e_r)
     go (CastIt co_l')                        (CastIt co_r')                        = return (init_rn2, \rn2 -> liftM CastIt $ msgCoercion rn2 co_l' co_r')
     go (Update x_l')                         (Update x_r')                         = return (second (liftM Update .) $ msgIdCoVarBndr' init_rn2 x_l' x_r')
diff --git a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs
index c614105..d245879 100644
--- a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs
+++ b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs
@@ -92,6 +92,10 @@ annedVar tg x = Comp (Tagged tg (Comp (Sized 1 (FVed (annedVarFreeVars' x) x))))
 annedAnswer :: Tag -> Answer -> Anned Answer
 annedAnswer tg a = Comp (Tagged tg (Comp (Sized (answerSize' a) (FVed (answerFreeVars' a) a))))
 
+annedQA :: Tag -> QA -> Anned QA
+annedQA tg (Question x) = fmap Question (annedVar tg x)
+annedQA tg (Answer a)   = fmap Answer (annedAnswer tg a)
+
 
 toAnnedTerm :: UniqSupply -> Term -> AnnedTerm
 toAnnedTerm tag_ids = tagFVedTerm tag_ids . reflect