[commit: ghc] : Fix the instantiation check in msgMatch (bd4c506)

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

On branch  : 

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

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

commit bd4c50646001688ddfdd58fa8aceea563e644c2b
Author: Max Bolingbroke <[email protected]>
Date:   Fri Apr 27 09:12:48 2012 +0100

    Fix the instantiation check in msgMatch

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

 compiler/supercompile/Supercompile/Drive/MSG.hs |   20 ++++++++++++++++----
 1 files changed, 16 insertions(+), 4 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs
index f5756c4..74fc782 100644
--- a/compiler/supercompile/Supercompile/Drive/MSG.hs
+++ b/compiler/supercompile/Supercompile/Drive/MSG.hs
@@ -433,10 +433,22 @@ msgMatch inst_mtch ((_, Heap h_l _, rn_l, k_l), (heap@(Heap _ ids), k, qa), (dee
   --     ones are only matched against heap-bound ones, and we don't have any generalisation flag to check on update frames.
   , Just h_is_gen <- forM (M.toList h_l) $ \(x_l, hb_l) -> case heapBindingLambdaBoundness hb_l of
                                                              Nothing -> Nothing
-                                                             Just gen_l -> Just (renameId rn_l_inv x_l, gen_l)
-  , all (\(x, gen_l) -> case M.lookup (renameId rn_r x) h_r of
-                          Nothing   -> error "(FIXME) msgMatch: Probably shouldn't happen"
-                          Just hb_r -> isJust (heapBindingLambdaBoundness hb_r) || mayInstantiate inst_mtch gen_l) h_is_gen
+                                                             Just gen_l -> Just (case () of
+                                                                                   () | isCoVar x_l, Just q_r <- getCoVar_maybe (lookupCoVarSubst rn_l_inv x_l) -> q_r
+                                                                                      | isId    x_l                                                             -> renameId rn_l_inv x_l
+                                                                                      | isTyVar x_l, Just a_r <- getTyVar_maybe (lookupTyVarSubst rn_l_inv x_l) -> a_r
+                                                                                      | otherwise   -> panic "msgMatch: impossible variable type/non-invertible renaming", gen_l)
+  , let k_r_bvs = stackBoundVars k_r
+        heap_non_instantiating x_r = case M.lookup x_r h_r of
+                         Nothing | x_r `elemVarSet` k_r_bvs -> True -- Instantiating with an update-frame bound thing is *probably* OK
+                         Just hb_r -> isJust (heapBindingLambdaBoundness hb_r)
+                         _ -> panic "msgMatch: variable unbound on right" -- (ppr rn_l $$ ppr rn_r $$ ppr x $$ ppr (renameId rn_l x) $$ ppr x_r)
+  , all (\(x, gen_l) -> mayInstantiate inst_mtch gen_l || case () of
+                          () | isCoVar x, let co_r = lookupCoVarSubst rn_r x -> maybe False heap_non_instantiating (getCoVar_maybe co_r)
+                             | isId x,    let x_r  = renameId rn_r x         -> heap_non_instantiating x_r
+                             | isTyVar x, let ty_r = lookupTyVarSubst rn_r x -> isJust (getTyVar_maybe ty_r)
+                             | otherwise -> panic "msgMatch: impossible variable type") -- TODO: perhaps type/covar instantiation should be unconditonally allowed?
+        h_is_gen
   = Just (RightIsInstance heap_r (composeRenamings ids rn_l_inv rn_r) k_r)
 
   -- Now look for type generalisation information