New functionality required for the supercompiler plugin

6 files changed, 63 insertions, 4 deletions

diff --git a/.gitignore b/.gitignore
index ac8c70e59d..2bfec1656b 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,6 +1,9 @@
 # -----------------------------------------------------------------------------
 # generic generated file patterns
 
+Thumbs.db
+.DS_Store
+
 *~
 #*#
 *.bak
@@ -233,4 +236,4 @@ _darcs/
 /utils/unlit/unlit
 
 
-/extra-gcc-opts
\ No newline at end of file
+/extra-gcc-opts
diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs
index fca625692f..a28136bd8a 100644
--- a/compiler/basicTypes/VarEnv.lhs
+++ b/compiler/basicTypes/VarEnv.lhs
@@ -35,8 +35,10 @@ module VarEnv (
 	RnEnv2, 
 	
 	-- ** Operations on RnEnv2s
-	mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR,
+	mkRnEnv2, rnBndr2, rnBndrs2,
+	rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe,
         rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR,
+        delBndrL, delBndrR, delBndrsL, delBndrsR,
         addRnInScopeSet,
         rnEtaL, rnEtaR,
 	rnInScope, rnInScopeSet, lookupRnInScope,
@@ -283,11 +285,24 @@ rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR
   where
     new_b = uniqAway in_scope bR
 
+delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2
+delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v }
+delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v }
+
+delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2
+delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v }
+delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v }
+
 rnOccL, rnOccR :: RnEnv2 -> Var -> Var
 -- ^ Look up the renaming of an occurrence in the left or right term
 rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v
 rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v
 
+rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var
+-- ^ Look up the renaming of an occurrence in the left or right term
+rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v
+rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v
+
 inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool
 -- ^ Tells whether a variable is locally bound
 inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index 3ba8afaad3..15800b1518 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -8,7 +8,8 @@ Utility functions on @Core@ syntax
 \begin{code}
 module CoreSubst (
 	-- * Main data types
-	Subst, TvSubstEnv, IdSubstEnv, InScopeSet,
+	Subst(..), -- Implementation exported for supercompiler's Renaming.hs only
+	TvSubstEnv, IdSubstEnv, InScopeSet,
 
         -- ** Substituting into expressions and related types
 	deShadowBinds, substSpec, substRulesForImportedIds,
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 4fd23ee712..95bc2d6014 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -701,6 +701,10 @@ stringTyConName         = tcQual  gHC_BASE (fsLit "String") stringTyConKey
 inlineIdName :: Name
 inlineIdName	 	= varQual gHC_MAGIC (fsLit "inline") inlineIdKey
 
+-- The 'undefined' function. Used by supercompilation.
+undefinedName :: Name
+undefinedName = varQual gHC_ERR (fsLit "undefined") undefinedKey
+
 -- Base classes (Eq, Ord, Functor)
 fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name
 eqClassName	  = clsQual  gHC_CLASSES (fsLit "Eq")      eqClassKey
@@ -1440,6 +1444,9 @@ marshalStringIdKey            = mkPreludeMiscIdUnique 96
 unmarshalStringIdKey          = mkPreludeMiscIdUnique 97
 checkDotnetResNameIdKey       = mkPreludeMiscIdUnique 98
 
+undefinedKey :: Unique
+undefinedKey		      = mkPreludeMiscIdUnique 99
+
 \end{code}
 
 Certain class operations from Prelude classes.  They get their own
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index fc4d919473..8a0c62a2ed 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -596,6 +596,10 @@ keyword = bold
 -- | Class designating that some type has an 'SDoc' representation
 class Outputable a where
 	ppr :: a -> SDoc
+	pprPrec :: Rational -> a -> SDoc
+	
+	ppr = pprPrec 0
+	pprPrec _ = ppr
 \end{code}
 
 \begin{code}
@@ -656,6 +660,27 @@ instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e)
 		   ppr d <> comma,
 		   ppr e])
 
+instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) =>
+	 Outputable (a, b, c, d, e, f) where
+    ppr (a,b,c,d,e,f) =
+      parens (sep [ppr a <> comma,
+		   ppr b <> comma,
+		   ppr c <> comma,
+		   ppr d <> comma,
+		   ppr e <> comma,
+		   ppr f])
+
+instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) =>
+	 Outputable (a, b, c, d, e, f, g) where
+    ppr (a,b,c,d,e,f,g) =
+      parens (sep [ppr a <> comma,
+		   ppr b <> comma,
+		   ppr c <> comma,
+		   ppr d <> comma,
+		   ppr e <> comma,
+		   ppr f <> comma,
+		   ppr g])
+
 instance Outputable FastString where
     ppr fs = ftext fs		-- Prints an unadorned string,
 				-- no double quotes or anything
diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs
index 7302b0295e..9c9fdc9bc4 100644
--- a/compiler/utils/UniqFM.lhs
+++ b/compiler/utils/UniqFM.lhs
@@ -64,7 +64,9 @@ import Outputable
 
 import Compiler.Hoopl   hiding (Unique)
 
+import Data.Function (on)
 import qualified Data.IntMap as M
+import qualified Data.Foldable as Foldable
 \end{code}
 
 %************************************************************************
@@ -161,7 +163,13 @@ ufmToList	:: UniqFM elt -> [(Unique, elt)]
 %************************************************************************
 
 \begin{code}
-newtype UniqFM ele = UFM (M.IntMap ele)
+newtype UniqFM ele = UFM { unUFM :: M.IntMap ele }
+
+instance Eq ele => Eq (UniqFM ele) where
+    (==) = (==) `on` unUFM
+
+instance Foldable.Foldable UniqFM where
+    foldMap f = Foldable.foldMap f . unUFM
 
 emptyUFM = UFM M.empty
 isNullUFM (UFM m) = M.null m