[commit: ghc] supercompiler: Fix stupid typo in MSG that was causing even stupider tiebacks (46b9179)

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

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/46b917947cfd0634700414375e05b91e01716d9e

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

commit 46b917947cfd0634700414375e05b91e01716d9e
Author: Max Bolingbroke <[email protected]>
Date:   Wed Sep 26 20:02:45 2012 +0100

    Fix stupid typo in MSG that was causing even stupider tiebacks

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

 compiler/supercompile/Supercompile/Drive/MSG.hs    |    4 ++--
 .../supercompile/Supercompile/Drive/Process3.hs    |   11 ++++++++---
 2 files changed, 10 insertions(+), 5 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs
index bed1a7d..6fcb4e4 100644
--- a/compiler/supercompile/Supercompile/Drive/MSG.hs
+++ b/compiler/supercompile/Supercompile/Drive/MSG.hs
@@ -1,5 +1,5 @@
 module Supercompile.Drive.MSG (
-    MSGMode(..), msg, msgMaybe,
+    MSGMode(..), MSGResult, msg, msgMaybe,
 
     InstanceMatching(..), MSGMatchResult(..), msgMatch
   ) where
@@ -1151,7 +1151,7 @@ initStack xs i (Car kf_l k_l) (Car kf_r k_r) = do
       _ -> return (xs, Nothing, Nothing)
     let suck = initSuckStackFrame i mb_x kf_l kf_r
     liftM (\(mxs, k_lrs, sucks) -> (maybe id (:) mb_mx mxs, liftA2 (\kf_lr (k_avail_lr, k_lr) -> (kf_lr `Car` k_avail_lr, k_lr)) (Pair kf_l kf_r) k_lrs, IM.insert i suck sucks)) $ initStack xs (i + 1) k_l k_r
-initStack _ _ k_l k_r = return ([], Pair (Loco (stackGeneralised k_l), k_r) (Loco (stackGeneralised k_r), k_r), IM.empty)
+initStack _ _ k_l k_r = return ([], Pair (Loco (stackGeneralised k_l), k_l) (Loco (stackGeneralised k_r), k_r), IM.empty)
 
 initSuckStackFrame :: Int -> Maybe (Var {- partial loop -}, Pair Var) -> Tagged StackFrame -> Tagged StackFrame -> MSGU ()
 initSuckStackFrame i mb_x (Tagged tg_l kf_l) (Tagged tg_r kf_r) = do
diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs
index 23a7574..5f75203 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -327,13 +327,12 @@ tryTaG opt shallow_state state = bothWays (\_ -> generaliseSplit opt gen) shallo
   where gen = mK_GENERALISER shallow_state state
 
 tryMSG opt = bothWays $ \shallow_state state -> do
-  (Pair _ (deeds_r, heap_r@(Heap h_r ids_r), rn_r, k_r), (heap@(Heap _ ids), k, qa)) <- msgMaybe (MSGMode { msgCommonHeapVars = case shallow_state of (_, Heap _ ids, _, _) -> ids }) shallow_state state
+  msg_result@(Pair _ (deeds_r, heap_r@(Heap h_r ids_r), rn_r, k_r), (heap@(Heap _ ids), k, qa)) <- msgMaybe (MSGMode { msgCommonHeapVars = case shallow_state of (_, Heap _ ids, _, _) -> ids }) shallow_state state
   -- NB: have to check that we throw away *some* info via MSG or else we can get a loop where we
   -- MSG back to the same state and thus create a loop (i.e. if previous state is (a, a)^t and new state is (b, c)^t)
   guard (not (isPureHeapEmpty h_r) || not (isStackEmpty k_r))
   let [deeds, deeds_r'] = splitDeeds deeds_r [heapSize heap + stackSize k + annedSize qa, heapSize heap_r + stackSize k_r]
-  pprTrace "MSG success" (pPrintFullState quietStatePrettiness (deeds, heap, k, qa) $$
-                          pPrintFullState quietStatePrettiness (deeds_r', heap_r, k_r, fmap Question (annedVar (mkTag 0) nullAddrId))) $ Just $ do
+  pprTrace "MSG success" (pprMSGResult msg_result) $ Just $ do
     (deeds', e) <- sc (deeds, heap, k, qa)
     -- Just to suppress warnings from renameId (since output term may mention h functions). Alternatively, I could rename the State I pass to "sc"
     -- NB: adding some new bindings to h_r for the h functions is a bit of a hack because:
@@ -342,6 +341,12 @@ tryMSG opt = bothWays $ \shallow_state state -> do
     (h_hs, e') <- renameSCResult ids (rn_r, e)
     instanceSplit opt (deeds' `plusDeeds` deeds_r', Heap (h_r `M.union` h_hs) ids_r, k_r, e')
 
+pprMSGResult :: MSGResult -> SDoc
+pprMSGResult (Pair (deeds_l, heap_l@(Heap h_l ids_l), rn_l, k_l) (deeds_r, heap_r@(Heap h_r ids_r), rn_r, k_r), (heap@(Heap _ ids), k, qa))
+  = pPrintFullState quietStatePrettiness (emptyDeeds, heap, k, qa) $$
+    pPrintFullState quietStatePrettiness (deeds_l, heap_l, k_l, fmap Question (annedVar (mkTag 0) nullAddrId)) $$
+    pPrintFullState quietStatePrettiness (deeds_r, heap_r, k_r, fmap Question (annedVar (mkTag 0) nullAddrId))
+
 renameSCResult :: InScopeSet -> In FVedTerm -> ScpM (PureHeap, FVedTerm)
 renameSCResult ids (rn_r, e) = do
     hs <- outputFreeVars