Commit c15fef6b authored by batterseapower's avatar batterseapower

New functionality required for the supercompiler plugin

parent aa40a7d3
# -----------------------------------------------------------------------------
# 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
......@@ -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
......
......@@ -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,
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment