[commit: ghc] : Some FIXMEs about common-heap-vars optimisation in presence of MSG (0b86b7a)

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

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/0b86b7a8f86e296e374c220b6539e1f51a9d60c9

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

commit 0b86b7a8f86e296e374c220b6539e1f51a9d60c9
Author: Max Bolingbroke <[email protected]>
Date:   Fri Apr 20 17:39:06 2012 +0100

    Some FIXMEs about common-heap-vars optimisation in presence of MSG

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

 compiler/supercompile/Supercompile/Drive/MSG.hs    |    8 +++++++-
 .../supercompile/Supercompile/Drive/Process3.hs    |    6 +++++-
 2 files changed, 12 insertions(+), 2 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs
index ebbc313..aa1bd64 100644
--- a/compiler/supercompile/Supercompile/Drive/MSG.hs
+++ b/compiler/supercompile/Supercompile/Drive/MSG.hs
@@ -132,13 +132,13 @@ data MSGState = MSGState {
 -- INVARIANT: incoming base variable has *no* extra information beyond Name and Type/Kind
 msgPend :: RnEnv2 -> Var -> Pending -> MSG Var
 msgPend rn2 x0 pending = MSG $ \_ s -> Right $ case lookupUpdatePending s of
+    Right x   -> (s, x)
     Left mk_s -> (s { msgInScopeSet = extendInScopeSet ids' x2,
                       msgPending = (x2, pending) : msgPending s }, x2)
       where s = mk_s x2
             -- This use of rn2 is necessary to ensure new common vars don't clash with rigid binders
             x1 = uniqAway (rnInScopeSet rn2) x0
             (ids', x2) = uniqAway' (msgInScopeSet s) x1
-    Right x   -> (s, x)
   where
     lookupUpdatePending s = case pending of
       PendingVar x_l x_r -> case mb_x_l_map >>= flip lookupVarEnv x_r of
@@ -308,6 +308,12 @@ type MSGResult = ((Deeds, Heap, Renaming, Stack), (Heap, Stack, Anned QA), (Deed
 -- we're going to satisfy the demand for the States on both sides by driving the (instantiable)
 -- common State.
 
+-- FIXME: MSG is currently breaking the "common heap vars" optimisation
+-- To make sure that it continues to work we need the property that:
+--  1. For every variable bound in the outgoing heap/stack of the {left,right} and common outgoing states..
+--  2. ..IF it is in the {left,right} incoming InScopeSet..
+--  3. ..then the thing it is bound in the {left,right} incoming state MUST have the same meaning as the new binding.
+
 msg :: MSGMode -- ^ How to match
     -> State   -- ^ Tieback semantics
     -> State   -- ^ This semantics
diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs
index 5b8e041..9460ea4 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -261,6 +261,7 @@ sc' mb_h state = {-# SCC "sc'" #-} case mb_h of
                  (speculateM (reduce state) $ \state -> my_split state sc)
                  (\shallow_h shallow_state shallow_rb -> trce shallow_h shallow_state $
                                                          case msg (MSGMode { msgCommonHeapVars = S.empty }) shallow_state state of 
+                                                           -- FIXME: use common heap vars once I fix the MSG issue preventing this optimisation (just supply shallow_state InScopeSet!)
                                                            -- FIXME: better? In particular, could rollback and then MSG
                                                            Just (_, (heap@(Heap _ ids), k, qa), (deeds_r, heap_r, rn_r, k_r))
                                                             -> pprTrace "MSG success" (pPrintFullState quietStatePrettiness (deeds, heap, k, qa) $$
@@ -363,7 +364,10 @@ memo opt init_state = {-# SCC "memo'" #-} memo_opt init_state
              | let (parented_ps, unparented_ps) = trainToList (promises (scpMemoState s))
              , (p, is_ancestor, common_h_vars) <- [ (p_sibling, fun p_parent == fun p_sibling, common_h_vars)
                                                   | (p_parent, p_siblings) <- parented_ps
-                                                  , let common_h_vars = case meaning p_parent of (_, Heap h _, _, _) -> M.keysSet h
+                                                  , let common_h_vars = S.empty
+                                                                        -- FIXME: the use of MSG prevents this optimisation (for now)
+                                                                        -- FIXME: shouldn't I just use the parent InScopeSet anyway??
+                                                                        -- case meaning p_parent of (_, Heap h _, _, _) -> M.keysSet h
                                                   , p_sibling <- p_parent:p_siblings ] ++
                                                   [ (p_root,    False,                         S.empty)
                                                   | p_root <- unparented_ps ]