Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-7.2
http://hackage.haskell.org/trac/ghc/changeset/40e4d4b2587ff670837500739fdb3c3c19760a1b >--------------------------------------------------------------- commit 40e4d4b2587ff670837500739fdb3c3c19760a1b Author: Max Bolingbroke <[email protected]> Date: Wed Jun 29 17:15:03 2011 +0100 New functionality required for the supercompiler plugin >--------------------------------------------------------------- .gitignore | 5 ++++- compiler/basicTypes/VarEnv.lhs | 17 ++++++++++++++++- compiler/coreSyn/CoreSubst.lhs | 3 ++- compiler/prelude/PrelNames.lhs | 7 +++++++ compiler/utils/Outputable.lhs | 25 +++++++++++++++++++++++++ compiler/utils/UniqFM.lhs | 10 +++++++++- 6 files changed, 63 insertions(+), 4 deletions(-) diff --git a/.gitignore b/.gitignore index ac8c70e..2bfec16 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 fca6256..a28136b 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 3ba8afa..15800b1 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 4fd23ee..95bc2d6 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 fc4d919..8a0c62a 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 7302b02..9c9fdc9 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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
