[commit: ghc] supercompiler: Carefully do inverted-rename on types in invertRenaming (e8b2ca3)

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

On branch  : supercompiler

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

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

commit e8b2ca32d152fe4e8929dc70f6f35a9ed946a496
Author: Max Bolingbroke <[email protected]>
Date:   Wed Apr 25 17:35:40 2012 +0100

    Carefully do inverted-rename on types in invertRenaming

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

 .../supercompile/Supercompile/Core/Renaming.hs     |   36 +++++++++++---------
 compiler/supercompile/Supercompile/Drive/MSG.hs    |    2 +-
 2 files changed, 21 insertions(+), 17 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Core/Renaming.hs b/compiler/supercompile/Supercompile/Core/Renaming.hs
index 4212526..b5308ce 100644
--- a/compiler/supercompile/Supercompile/Core/Renaming.hs
+++ b/compiler/supercompile/Supercompile/Core/Renaming.hs
@@ -50,6 +50,8 @@ import FastString  (FastString)
 import UniqFM      (ufmToList)
 import VarEnv
 
+import Control.Monad.Fix (mfix)
+
 import qualified Data.Map as M
 
 
@@ -148,22 +150,24 @@ mkRenaming rn = foldVarlikes (\f -> M.foldWithKey (\x x' -> f x (x, x'))) rn
                              (\(q, q') -> third3  (\co_subst -> extendVarEnv co_subst q (mkCoVarCo q')))
                              (emptyVarEnv, emptyVarEnv, emptyVarEnv)
 
-invertRenaming :: Renaming -> Maybe Renaming
-invertRenaming (id_subst, tv_subst, co_subst)
-  = liftM3 (,,) (traverse coreSynToVar_maybe id_subst >>= invertVarEnv varToCoreSyn mkSysLocal)
-                (traverse getTyVar_maybe     tv_subst >>= invertVarEnv mkTyVarTy    (\fs uniq -> mkTyVar (mkSysTvName uniq fs)))
-                (traverse getCoVar_maybe     co_subst >>= invertVarEnv mkCoVarCo    mkSysLocal)
-  where
-    -- FIXME: this inversion relies on something of a hack because the domain of the mapping is not stored (only its Unique)
-    invertVarEnv :: (Var -> a)
-                 -> (FastString -> Unique -> Type -> Var)
-                 -> VarEnv Var -> Maybe (VarEnv a)
-    invertVarEnv promote mk env
-      | distinct (varEnvElts env) = Just (mkVarEnv [ (x, promote $ if isGlobalId x && u == varUnique x
-                                                                    then x -- So we don't replace global Ids with new local Ids!
-                                                                    else mk (occNameFS (getOccName x)) u (varType x))
-                                                   | (u, x) <- ufmToList env])
-      | otherwise                 = Nothing
+-- NB: the InScopeSet should be that of the *domain* of the renaming (I think!)
+invertRenaming :: InScopeSet -> Renaming -> Maybe Renaming
+invertRenaming ids (id_subst, tv_subst, co_subst)
+  = mfix $ \rn -> let -- FIXME: this inversion relies on something of a hack because the domain of the mapping is not stored (only its Unique)
+                      -- Furthermore, we want to carefully rename the *types* (and extra info, if we actually preserved any) as well when doing
+                      -- this inversion so that the renaming {a |-> b, y |-> x :: b} is inverted to {b |-> a, x |-> y :: a}
+                      invertVarEnv :: (Var -> a)
+                                   -> (FastString -> Unique -> Type -> Var)
+                                   -> VarEnv Var -> Maybe (VarEnv a)
+                      invertVarEnv promote mk env
+                        | distinct (varEnvElts env) = Just (mkVarEnv [ (x, promote $ if isGlobalId x && u == varUnique x
+                                                                                      then x -- So we don't replace global Ids with new local Ids!
+                                                                                      else mk (occNameFS (getOccName x)) u (renameType ids rn (varType x)))
+                                                                     | (u, x) <- ufmToList env])
+                        | otherwise                 = Nothing
+                  in liftM3 (,,) (traverse coreSynToVar_maybe id_subst >>= invertVarEnv varToCoreSyn mkSysLocal)
+                                 (traverse getTyVar_maybe     tv_subst >>= invertVarEnv mkTyVarTy    (\fs uniq -> mkTyVar (mkSysTvName uniq fs)))
+                                 (traverse getCoVar_maybe     co_subst >>= invertVarEnv mkCoVarCo    mkSysLocal)
 
 -- NB: we want the set of things in scope in the range of the first renaming / domain of the second renaming
 composeRenamings :: InScopeSet -> Renaming -> Renaming -> Renaming
diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs
index 81ece8c..167fc7b 100644
--- a/compiler/supercompile/Supercompile/Drive/MSG.hs
+++ b/compiler/supercompile/Supercompile/Drive/MSG.hs
@@ -413,7 +413,7 @@ msgMatch :: InstanceMatching -> MSGResult -> Maybe MSGMatchResult
 msgMatch inst_mtch ((_, Heap h_l _, rn_l, k_l), (heap@(Heap _ ids), k, qa), (deeds_r, heap_r@(Heap h_r _), rn_r, k_r))
   -- Try to detect instantiation first
   --  1) Is the left-hand renaming invertible?
-  | Just rn_l_inv <- invertRenaming rn_l
+  | Just rn_l_inv <- invertRenaming ids rn_l
   --  2) Is the left-hand stack empty, and if has been instantiated on the right, was that valid?
   , Loco gen_k_l <- k_l
   , case k_r of Loco _ -> True