[commit: ghc] supercompiler: Always allow type/coercion instantiation in MSG as experiment (8e6ef76)

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

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/8e6ef7666750d863a7371d95859615294b8b12fe

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

commit 8e6ef7666750d863a7371d95859615294b8b12fe
Author: Max Bolingbroke <[email protected]>
Date:   Fri May 25 10:32:57 2012 +0100

    Always allow type/coercion instantiation in MSG as experiment

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

 compiler/supercompile/Supercompile/Drive/MSG.hs   |    6 +++---
 compiler/supercompile/Supercompile/StaticFlags.hs |    2 ++
 2 files changed, 5 insertions(+), 3 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs
index 1846def..731f960 100644
--- a/compiler/supercompile/Supercompile/Drive/MSG.hs
+++ b/compiler/supercompile/Supercompile/Drive/MSG.hs
@@ -15,6 +15,7 @@ import Supercompile.Evaluator.Syntax
 
 import qualified Supercompile.GHC as GHC
 import Supercompile.Utilities hiding (guard)
+import Supercompile.StaticFlags
 
 import qualified CoreSyn as Core
 
@@ -448,15 +449,14 @@ msgMatch inst_mtch ((_, Heap h_l _, rn_l, k_l), (heap@(Heap _ ids), k, qa), (dee
   , flip all (M.toList h_l) $ \(x_l, hb_l) -> case heapBindingLambdaBoundness hb_l of
                                                 Nothing -> False
                                                 Just gen_l -> mayInstantiate inst_mtch gen_l || case () of
-                                                                      () | isCoVar x_l, Just q <- lookupVarEnv rn_l_inv_qs x_l, let co_r = lookupCoVarSubst rn_r q -> maybe False heap_non_instantiating (getCoVar_maybe co_r)
+                                                                      () | isCoVar x_l, Just q <- lookupVarEnv rn_l_inv_qs x_l, let co_r = lookupCoVarSubst rn_r q -> tYPE_GEN || maybe False heap_non_instantiating (getCoVar_maybe co_r)
                                                                          | isId    x_l, Just x <- lookupVarEnv rn_l_inv_xs x_l, let x_r  = renameId rn_r x         -> heap_non_instantiating x_r
-                                                                         | isTyVar x_l, Just a <- lookupVarEnv rn_l_inv_as x_l, let ty_r = lookupTyVarSubst rn_r a -> isJust (getTyVar_maybe ty_r)
+                                                                         | isTyVar x_l, Just a <- lookupVarEnv rn_l_inv_as x_l, let ty_r = lookupTyVarSubst rn_r a -> tYPE_GEN || isJust (getTyVar_maybe ty_r)
                                                                          -- This case occurs when a heap binding is pulled in on one side by "sucks" but without
                                                                          -- being paired with one on the other side (e.g. 'x' in the example above). If this happens
                                                                          -- we'll just say True, though we'll probably reject the instantiation eventuall when we come
                                                                          -- to the binding on this side that caused the pulling-in to happen.
                                                                          | otherwise -> True
-                                                                         -- TODO: perhaps type/covar instantiation should be unconditonally allowed?
                                                                          -- TODO: what if we "instantiate" with some IdInfo on the left? Should that be disallowed?
   = Just (RightIsInstance heap_r (composeRenamings rn_l_inv rn_r) k_r)
 
diff --git a/compiler/supercompile/Supercompile/StaticFlags.hs b/compiler/supercompile/Supercompile/StaticFlags.hs
index f131407..b5d55dc 100644
--- a/compiler/supercompile/Supercompile/StaticFlags.hs
+++ b/compiler/supercompile/Supercompile/StaticFlags.hs
@@ -201,6 +201,8 @@ gENERALISATION = parseEnum "-fsupercompiler-generalisation" StackFirst [("none",
 oCCURRENCE_GENERALISATION :: Bool
 oCCURRENCE_GENERALISATION = not $ lookUp $ fsLit "-fsupercompiler-no-occurrence-generalisation"
 
+tYPE_GEN :: Bool
+tYPE_GEN = True
 
 eVALUATE_PRIMOPS :: Bool
 eVALUATE_PRIMOPS = not $ lookUp $ fsLit "-fsupercompiler-no-primops"