New functionality required for the supercompiler plugin
authorMax Bolingbroke <batterseapower@hotmail.com>
Wed, 29 Jun 2011 16:15:03 +0000 (17:15 +0100)
committerMax Bolingbroke <batterseapower@hotmail.com>
Wed, 29 Jun 2011 16:15:50 +0000 (17:15 +0100)
.gitignore
compiler/basicTypes/VarEnv.lhs
compiler/coreSyn/CoreSubst.lhs
compiler/prelude/PrelNames.lhs
compiler/utils/Outputable.lhs
compiler/utils/UniqFM.lhs

index ac8c70e..2bfec16 100644 (file)
@@ -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
index fca6256..a28136b 100644 (file)
@@ -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
index 3ba8afa..15800b1 100644 (file)
@@ -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,
index 4fd23ee..95bc2d6 100644 (file)
@@ -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
index fc4d919..8a0c62a 100644 (file)
@@ -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
index 7302b02..9c9fdc9 100644 (file)
@@ -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