Skip to content

GitLab

Commit bd1ca0d3 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Removal of eval annotations

parent 59d66221
Hide whitespace changes
Inline Side-by-side
Showing with 56 additions and 203 deletions
curry-frontend.cabal
View file @ bd1ca0d3
......@@ -62,7 +62,6 @@ Executable cymake
, CompilerOpts
, CurryBuilder
, CurryDeps
, Env.Eval
, Env.Interface
, Env.ModuleAlias
, Env.OpPrec
......
src/Base/Expr.hs
View file @ bd1ca0d3
......@@ -63,7 +63,6 @@ instance QualExpr Decl where
instance QuantExpr Decl where
bv (TypeSig _ vs _) = vs
bv (EvalAnnot _ fs _) = fs
bv (FunctionDecl _ f _) = [f]
bv (ExternalDecl _ _ _ f _) = [f]
bv (FlatExternalDecl _ fs) = fs
......
src/Checks/SyntaxCheck.lhs
View file @ bd1ca0d3
......@@ -355,8 +355,6 @@ top-level.
> InfixDecl p fix' pr `liftM` mapM renameVar ops
> checkDeclLhs (TypeSig p vs ty) =
> (\vs' -> TypeSig p vs' ty) `liftM` mapM (checkVar "type signature") vs
> checkDeclLhs (EvalAnnot p fs ev) =
> (\fs' -> EvalAnnot p fs' ev) `liftM` mapM (checkVar "evaluation annotation") fs
> checkDeclLhs (FunctionDecl p _ eqs) =
> checkEquationsLhs p eqs
> checkDeclLhs (ExternalDecl p cc ie f ty) =
......@@ -452,10 +450,9 @@ top-level.
> checkDecls :: (Decl -> RenameEnv -> RenameEnv) -> [Decl] -> SCM [Decl]
> checkDecls bindDecl ds = do
> let dbls@[dblVar, dblTys, dblEAs] = map findDouble [bvs, tys, evs]
> let dbls@[dblVar, dblTys] = map findDouble [bvs, tys]
> onJust (report . errDuplicateDefinition) dblVar
> onJust (report . errDuplicateTypeSig ) dblTys
> onJust (report . errDuplicateEvalAnnot ) dblEAs
> let missingTy = [f | FlatExternalDecl _ fs' <- ds, f <- fs', f `notElem` tys]
> mapM_ (report . errNoTypeSig) missingTy
> if all isNothing dbls && null missingTy
......@@ -467,7 +464,6 @@ top-level.
> tds = filter isTypeSig ds
> bvs = concatMap vars vds
> tys = concatMap vars tds
> evs = concatMap vars $ filter isEvalAnnot ds
> onJust = maybe (return ())
-- ---------------------------------------------------------------------------
......@@ -475,8 +471,6 @@ top-level.
> checkDeclRhs :: [Ident] -> Decl -> SCM Decl
> checkDeclRhs bvs (TypeSig p vs ty) =
> (\vs' -> TypeSig p vs' ty) `liftM` mapM (checkLocalVar bvs) vs
> checkDeclRhs bvs (EvalAnnot p vs ev) =
> (\vs' -> EvalAnnot p vs' ev) `liftM` mapM (checkLocalVar bvs) vs
> checkDeclRhs _ (FunctionDecl p f eqs) =
> FunctionDecl p f `liftM` mapM checkEquation eqs
> checkDeclRhs _ (PatternDecl p t rhs) =
......@@ -857,7 +851,6 @@ Auxiliary definitions.
> vars :: Decl -> [Ident]
> vars (TypeSig _ fs _) = fs
> vars (EvalAnnot _ fs _) = fs
> vars (FunctionDecl _ f _) = [f]
> vars (ExternalDecl _ _ _ f _) = [f]
> vars (FlatExternalDecl _ fs) = fs
......@@ -1027,10 +1020,6 @@ Error messages.
> errDuplicateTypeSig v = posMessage v $ hsep $ map text
> ["More than one type signature for", escName v]
> errDuplicateEvalAnnot :: Ident -> Message
> errDuplicateEvalAnnot v = posMessage v $ hsep $ map text
> ["More than one eval annotation for", escName v]
> errDuplicateLabel :: Ident -> Message
> errDuplicateLabel l = posMessage l $ hsep $ map text
> ["Multiple occurrence of record label", escName l]
......
src/CompilerEnv.hs
View file @ bd1ca0d3
......@@ -20,7 +20,6 @@ import Curry.Base.Ident (ModuleIdent)
import Base.TopEnv (allLocalBindings)
import Env.Eval
import Env.Interface
import Env.ModuleAlias
import Env.OpPrec
......@@ -37,7 +36,6 @@ data CompilerEnv = CompilerEnv
, tyConsEnv :: TCEnv -- ^ type constructors
, valueEnv :: ValueEnv -- ^ functions and data constructors
, opPrecEnv :: PEnv -- ^ operator precedences
, evalAnnotEnv :: EvalEnv -- ^ evaluation annotations
}
initCompilerEnv :: ModuleIdent -> CompilerEnv
......@@ -48,7 +46,6 @@ initCompilerEnv mid = CompilerEnv
, tyConsEnv = initTCEnv
, valueEnv = initDCEnv
, opPrecEnv = initPEnv
, evalAnnotEnv = initEEnv
}
showCompilerEnv :: CompilerEnv -> String
......@@ -59,7 +56,6 @@ showCompilerEnv env = show $ vcat
, header "TypeConstructors" $ ppAL $ allLocalBindings $ tyConsEnv env
, header "Values " $ ppAL $ allLocalBindings $ valueEnv env
, header "Precedences " $ ppAL $ allLocalBindings $ opPrecEnv env
, header "Eval Annotations" $ ppMap $ evalAnnotEnv env
]
where
header hdr content = hang (text hdr <+> colon) 4 content
......
src/Env/Eval.hs deleted 100644 → 0
View file @ 59d66221
{- |
Module : $Header$
Description : Environment of Evaluation Annotations
Copyright : (c) 2001-2004, Wolfgang Lux
2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
This module computes the evaluation annotation environment. There is no
need to check the annotations because this happens already while checking
the definitions of the module.
-}
module Env.Eval (EvalEnv, initEEnv, evalEnv) where
import qualified Data.Map as Map (Map, empty, insert)
import Curry.Base.Ident (Ident)
import Curry.Syntax
type EvalEnv = Map.Map Ident EvalAnnotation
initEEnv :: EvalEnv
initEEnv = Map.empty
-- |The function 'evalEnv' collects all evaluation annotations of
-- the module by traversing the syntax tree.
evalEnv :: Module -> EvalEnv
evalEnv (Module _ _ _ ds) = foldr annDecl initEEnv ds
annDecl :: Decl -> EvalEnv -> EvalEnv
annDecl (EvalAnnot _ fs ev) env = foldr (`Map.insert` ev) env fs
annDecl (FunctionDecl _ _ eqs) env = foldr annEquation env eqs
annDecl (PatternDecl _ _ rhs) env = annRhs rhs env
annDecl _ env = env
annEquation :: Equation -> EvalEnv -> EvalEnv
annEquation (Equation _ _ rhs) = annRhs rhs
annRhs :: Rhs -> EvalEnv -> EvalEnv
annRhs (SimpleRhs _ e ds) env = annExpr e (foldr annDecl env ds)
annRhs (GuardedRhs es ds) env = foldr annCondExpr (foldr annDecl env ds) es
annCondExpr :: CondExpr -> EvalEnv -> EvalEnv
annCondExpr (CondExpr _ g e) env = annExpr g (annExpr e env)
annExpr :: Expression -> EvalEnv -> EvalEnv
annExpr (Literal _) env = env
annExpr (Variable _) env = env
annExpr (Constructor _) env = env
annExpr (Paren e) env = annExpr e env
annExpr (Typed e _) env = annExpr e env
annExpr (Tuple _ es) env = foldr annExpr env es
annExpr (List _ es) env = foldr annExpr env es
annExpr (ListCompr _ e qs) env = annExpr e (foldr annStatement env qs)
annExpr (EnumFrom e) env = annExpr e env
annExpr (EnumFromThen e1 e2) env = annExpr e1 (annExpr e2 env)
annExpr (EnumFromTo e1 e2) env = annExpr e1 (annExpr e2 env)
annExpr (EnumFromThenTo e1 e2 e3) env = annExpr e1 (annExpr e2 (annExpr e3 env))
annExpr (UnaryMinus _ e) env = annExpr e env
annExpr (Apply e1 e2) env = annExpr e1 (annExpr e2 env)
annExpr (InfixApply e1 _ e2) env = annExpr e1 (annExpr e2 env)
annExpr (LeftSection e _) env = annExpr e env
annExpr (RightSection _ e) env = annExpr e env
annExpr (Lambda _ _ e) env = annExpr e env
annExpr (Let ds e) env = foldr annDecl (annExpr e env) ds
annExpr (Do sts e) env = foldr annStatement (annExpr e env) sts
annExpr (IfThenElse _ e1 e2 e3) env = annExpr e1 (annExpr e2 (annExpr e3 env))
annExpr (Case _ e alts) env = annExpr e (foldr annAlt env alts)
annExpr (RecordConstr fs) env = foldr (annExpr . fieldTerm) env fs
annExpr (RecordSelection e _) env = annExpr e env
annExpr (RecordUpdate fs e) env = foldr (annExpr . fieldTerm) (annExpr e env) fs
annStatement :: Statement -> EvalEnv -> EvalEnv
annStatement (StmtExpr _ e) env = annExpr e env
annStatement (StmtDecl ds) env = foldr annDecl env ds
annStatement (StmtBind _ _ e) env = annExpr e env
annAlt :: Alt -> EvalEnv -> EvalEnv
annAlt (Alt _ _ rhs) = annRhs rhs
src/Generators/GenAbstractCurry.hs
View file @ bd1ca0d3
......@@ -105,8 +105,6 @@ partitionDecl p d@(TypeDecl _ _ _ _) = p { typeDecls = d : typeDecls p }
-- function declarations
partitionDecl p (TypeSig pos ids ty)
= partitionFuncDecls (\q -> TypeSig pos [q] ty) p ids
partitionDecl p (EvalAnnot pos ids ann)
= partitionFuncDecls (\q -> EvalAnnot pos [q] ann) p ids
partitionDecl p d@(FunctionDecl _ ident _)
= partitionFuncDecls (const d) p [ident]
partitionDecl p d@(ExternalDecl _ _ _ ident _)
......@@ -235,10 +233,11 @@ genFuncDecl isLocal env (ident, decls)
where
qname = genQName False env $ qualify ident
visibility = genVisibility env ident
evalannot = case find isEvalAnnot decls of
Nothing -> CFlex
Just (EvalAnnot _ _ ea) -> genEvalAnnot ea
_ -> internalError "Gen.GenAbstractCurry.genFuncDecl: no Eval Annotation"
evalannot = CFlex
-- evalannot = case find isEvalAnnot decls of
-- Nothing -> CFlex
-- Just (EvalAnnot _ _ ea) -> genEvalAnnot ea
-- _ -> internalError "Gen.GenAbstractCurry.genFuncDecl: no Eval Annotation"
(env1, mtype) = case genFuncType env decls of
Nothing -> (env, Nothing)
Just (env', t) -> (env', Just t)
......@@ -659,11 +658,6 @@ genVisibility env ident
| isExported env ident = Public
| otherwise = Private
--
genEvalAnnot :: EvalAnnotation -> CEvalAnnot
genEvalAnnot EvalRigid = CRigid
genEvalAnnot EvalChoice = CChoice
-------------------------------------------------------------------------------
-- This part defines an environment containing all necessary information
-- for generating the AbstractCurry representation of a CurrySyntax term.
......
src/Html/SyntaxColoring.hs
View file @ bd1ca0d3
......@@ -419,11 +419,11 @@ code2qualString x = code2string x
token2code :: Token -> Code
token2code tok@(Token cat _)
| elem cat [IntTok,FloatTok,IntegerTok]
| elem cat [IntTok,FloatTok]
= NumberCode (token2string tok)
| elem cat [KW_case,KW_choice,KW_data,KW_do,KW_else,KW_eval,KW_external,
| elem cat [KW_case,KW_data,KW_do,KW_else,KW_external,
KW_free,KW_if,KW_import,KW_in,KW_infix,KW_infixl,KW_infixr,
KW_let,KW_module,KW_newtype,KW_of,KW_rigid,KW_then,KW_type,
KW_let,KW_module,KW_newtype,KW_of,KW_then,KW_type,
KW_where,Id_as,Id_ccall,Id_forall,Id_hiding,Id_interface,Id_primitive,
Id_qualified]
= Keyword (token2string tok)
......@@ -455,7 +455,6 @@ declPos (DataDecl p _ _ _ ) = p
declPos (NewtypeDecl p _ _ _ ) = p
declPos (TypeDecl p _ _ _ ) = p
declPos (TypeSig p _ _ ) = p
declPos (EvalAnnot p _ _ ) = p
declPos (FunctionDecl p _ _ ) = p
declPos (ExternalDecl p _ _ _ _) = p
declPos (FlatExternalDecl p _ ) = p
......@@ -537,8 +536,6 @@ decl2codes (TypeDecl _ ident idents typeExpr) =
typeExpr2codes typeExpr
decl2codes (TypeSig _ idents typeExpr) =
map (Function TypSig . qualify) idents ++ typeExpr2codes typeExpr
decl2codes (EvalAnnot _ idents _) =
map (Function FunDecl . qualify) idents
decl2codes (FunctionDecl _ _ equations) =
concatMap equation2codes equations
decl2codes (ExternalDecl _ _ _ _ _) =
......@@ -701,7 +698,6 @@ token2string (Token QSym a) = attributes2string a
token2string (Token IntTok a) = attributes2string a
token2string (Token FloatTok a) = attributes2string a
token2string (Token CharTok a) = attributes2string a
token2string (Token IntegerTok a) = attributes2string a
token2string (Token StringTok a) = attributes2string a
token2string (Token LeftParen _) = "("
token2string (Token RightParen _) = ")"
......@@ -729,11 +725,9 @@ token2string (Token SymDot _) = "."
token2string (Token SymMinus _) = "-"
token2string (Token SymMinusDot _) = "-."
token2string (Token KW_case _) = "case"
token2string (Token KW_choice _) = "choice"
token2string (Token KW_data _) = "data"
token2string (Token KW_do _) = "do"
token2string (Token KW_else _) = "else"
token2string (Token KW_eval _) = "eval"
token2string (Token KW_external _) = "external"
token2string (Token KW_free _) = "free"
token2string (Token KW_if _) = "if"
......@@ -746,7 +740,6 @@ token2string (Token KW_let _) = "let"
token2string (Token KW_module _) = "module"
token2string (Token KW_newtype _) = "newtype"
token2string (Token KW_of _) = "of"
token2string (Token KW_rigid _) = "rigid"
token2string (Token KW_then _) = "then"
token2string (Token KW_type _) = "type"
token2string (Token KW_where _) = "where"
......@@ -764,14 +757,12 @@ token2string (Token NestedComment (StringAttributes sv _)) = sv
token2string (Token NestedComment a) = attributes2string a
token2string (Token LeftBraceSemicolon _) = "{;"
token2string (Token Binds _) = ":="
token2string (Token Pragma a) = "{-#" ++ attributes2string a ++ "#-}"
attributes2string :: Attributes -> [Char]
attributes2string NoAttributes = ""
attributes2string (CharAttributes cv _) = showCh cv
attributes2string (IntAttributes iv _) = show iv
attributes2string (FloatAttributes fv _) = show fv
attributes2string (IntegerAttributes iv _) = show iv
attributes2string (StringAttributes sv _) = showSt sv
attributes2string (IdentAttributes mIdent ident) =concat (intersperse "." (mIdent ++ [ident]))
......
src/Modules.hs
View file @ bd1ca0d3
......@@ -31,8 +31,6 @@ import Curry.Files.PathUtils
import Base.Messages (abortWith, abortWithMessages, putErrsLn)
import Env.Eval (evalEnv)
-- source representations
import qualified Curry.AbstractCurry as AC
import qualified Curry.ExtendedFlat.Type as EF
......@@ -202,8 +200,7 @@ transModule :: Options -> CompilerEnv -> CS.Module
transModule opts env mdl = (env5, ilCaseComp, dumps)
where
flat' = FlatCurry `elem` optTargetTypes opts
env0 = env { evalAnnotEnv = evalEnv mdl }
(desugared , env1) = desugar mdl env0
(desugared , env1) = desugar mdl env
(simplified, env2) = simplify flat' desugared env1
(lifted , env3) = lift simplified env2
(il , env4) = ilTrans flat' lifted env3
......
src/Transformations.hs
View file @ bd1ca0d3
......@@ -39,7 +39,7 @@ completeCase mdl env = (CC.completeCase (interfaceEnv env) mdl, env)
-- |Translate into the intermediate language
ilTrans :: Bool -> Module -> CompilerEnv -> (IL.Module, CompilerEnv)
ilTrans flat mdl env = (il, env)
where il = IL.ilTrans flat (valueEnv env) (tyConsEnv env) (evalAnnotEnv env) mdl
where il = IL.ilTrans flat (valueEnv env) (tyConsEnv env) mdl
-- |Translate a type into its representation in the intermediate language
translType :: ModuleIdent -> ValueEnv -> TCEnv -> Type -> IL.Type
......@@ -52,8 +52,8 @@ desugar mdl env = (mdl', env { valueEnv = tyEnv' })
-- |Lift local declarations
lift :: Module -> CompilerEnv -> (Module, CompilerEnv)
lift mdl env = (mdl', env { valueEnv = tyEnv', evalAnnotEnv = eEnv' })
where (mdl', tyEnv', eEnv') = L.lift (valueEnv env) (evalAnnotEnv env) mdl
lift mdl env = (mdl', env { valueEnv = tyEnv' })
where (mdl', tyEnv') = L.lift (valueEnv env) mdl
-- |Fully qualify used constructors and functions
qual :: Options -> CompilerEnv -> Module -> (CompilerEnv, Module)
......@@ -63,4 +63,4 @@ qual opts env (Module m es is ds) = (qualifyEnv opts env, Module m es is ds')
-- |Simplify the source code
simplify :: Bool -> Module -> CompilerEnv -> (Module, CompilerEnv)
simplify flat mdl env = (mdl', env { valueEnv = tyEnv' })
where (mdl', tyEnv') = S.simplify flat (valueEnv env) (evalAnnotEnv env) mdl
where (mdl', tyEnv') = S.simplify flat (valueEnv env) mdl
src/Transformations/CurryToIL.lhs
View file @ bd1ca0d3
......@@ -34,7 +34,6 @@ data structures, we can use only a qualified import for the
> import Base.Types
> import Base.Utils (foldr2, thd3)
> import Env.Eval (EvalEnv)
> import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
> import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
......@@ -50,22 +49,21 @@ these types are already fully expanded, i.e., they do not include any
alias types.
\begin{verbatim}
> ilTrans :: Bool -> ValueEnv -> TCEnv -> EvalEnv -> Module -> IL.Module
> ilTrans flat tyEnv tcEnv evEnv (Module m _ _ ds) =
> IL.Module m (imports m ds') ds'
> where ds' = concatMap (translGlobalDecl flat m tyEnv tcEnv evEnv) ds
> ilTrans :: Bool -> ValueEnv -> TCEnv -> Module -> IL.Module
> ilTrans flat tyEnv tcEnv (Module m _ _ ds) = IL.Module m (imports m ds') ds'
> where ds' = concatMap (translGlobalDecl flat m tyEnv tcEnv) ds
> translGlobalDecl :: Bool -> ModuleIdent -> ValueEnv -> TCEnv -> EvalEnv
> translGlobalDecl :: Bool -> ModuleIdent -> ValueEnv -> TCEnv
> -> Decl -> [IL.Decl]
> translGlobalDecl _ m tyEnv tcEnv _ (DataDecl _ tc tvs cs) =
> translGlobalDecl _ m tyEnv tcEnv (DataDecl _ tc tvs cs) =
> [translData m tyEnv tcEnv tc tvs cs]
> translGlobalDecl _ m tyEnv tcEnv _ (NewtypeDecl _ tc tvs nc) =
> translGlobalDecl _ m tyEnv tcEnv (NewtypeDecl _ tc tvs nc) =
> [translNewtype m tyEnv tcEnv tc tvs nc]
> translGlobalDecl flat m tyEnv tcEnv evEnv (FunctionDecl pos f eqs) =
> [translFunction pos flat m tyEnv tcEnv evEnv f eqs]
> translGlobalDecl _ m tyEnv tcEnv _ (ExternalDecl _ cc ie f _) =
> translGlobalDecl flat m tyEnv tcEnv (FunctionDecl pos f eqs) =
> [translFunction pos flat m tyEnv tcEnv f eqs]
> translGlobalDecl _ m tyEnv tcEnv (ExternalDecl _ cc ie f _) =
> [translExternal m tyEnv tcEnv f cc (fromJust ie)]
> translGlobalDecl _ _ _ _ _ _ = []
> translGlobalDecl _ _ _ _ _ = []
> translData :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> [Ident] -> [ConstrDecl]
> -> IL.Decl
......@@ -255,8 +253,8 @@ uses flexible matching.
> type RenameEnv = Map.Map Ident Ident
> translFunction :: Position -> Bool -> ModuleIdent -> ValueEnv -> TCEnv
> -> EvalEnv -> Ident -> [Equation] -> IL.Decl
> translFunction pos flat m tyEnv tcEnv evEnv f eqs =
> -> Ident -> [Equation] -> IL.Decl
> translFunction pos flat m tyEnv tcEnv f eqs =
> -- - | f == mkIdent "fun" = error (show (translType' m tyEnv tcEnv ty))
> -- - | otherwise =
> IL.FunctionDecl f' vs (translType' m tyEnv tcEnv ty) expr
......@@ -265,29 +263,30 @@ uses flexible matching.
> where f' = qualifyWith m f
> ty = varType tyEnv f'
> -- ty' = elimRecordType m tyEnv tcEnv (maximum (0:(typeVars ty))) ty
> ev' = Map.lookup f evEnv
> ev = maybe (defaultMode ty) evalMode ev'
> -- ev' = Map.lookup f evEnv
> ev = IL.Flex -- = maybe (defaultMode ty) evalMode ev'
> vs = if not flat && isFpSelectorId f then translArgs eqs vs' else vs'
> (vs',vs'') = splitAt (equationArity (head eqs))
> (argNames (mkIdent ""))
> expr | ev' == Just EvalChoice
> = IL.Apply
> (IL.Function
> (qualifyWith preludeMIdent (mkIdent "commit"))
> 1)
> (match (srcRefOf pos) IL.Rigid vs
> (map (translEquation tyEnv vs vs'') eqs))
> | otherwise
> expr
> -- | ev' == Just EvalChoice
> -- = IL.Apply
> -- (IL.Function
> -- (qualifyWith preludeMIdent (mkIdent "commit"))
> -- 1)
> -- (match (srcRefOf pos) IL.Rigid vs
> -- (map (translEquation tyEnv vs vs'') eqs))
> -- | otherwise
> = match (srcRefOf pos) ev vs (map (translEquation tyEnv vs vs'') eqs)
> ---
> -- (vs',vs'') = splitAt (arrowArity ty) (argNames (mkIdent ""))
> evalMode :: EvalAnnotation -> IL.Eval
> evalMode EvalRigid = IL.Rigid
> evalMode EvalChoice = error "eval choice is not yet supported"
> -- evalMode :: EvalAnnotation -> IL.Eval
> -- evalMode EvalRigid = IL.Rigid
> -- evalMode EvalChoice = error "eval choice is not yet supported"
> defaultMode :: Type -> IL.Eval
> defaultMode _ = IL.Flex
> -- defaultMode :: Type -> IL.Eval
> -- defaultMode _ = IL.Flex
>
> --defaultMode ty = if isIO (arrowBase ty) then IL.Rigid else IL.Flex
> -- where TypeConstructor qIOId _ = ioType undefined
......
src/Transformations/Lift.lhs
View file @ bd1ca0d3
......@@ -32,15 +32,14 @@ lifted to the top-level.
> import Base.SCC
> import Base.Types
> import Env.Eval (EvalEnv)
> import Env.Value
> lift :: ValueEnv -> EvalEnv -> Module -> (Module, ValueEnv, EvalEnv)
> lift tyEnv evEnv (Module m es is ds) = (lifted, tyEnv', evEnv')
> lift :: ValueEnv -> Module -> (Module, ValueEnv)
> lift tyEnv (Module m es is ds) = (lifted, tyEnv')
> where
> lifted = Module m es is $ concatMap liftFunDecl ds'
> (ds', tyEnv', evEnv') = evalAbstract (abstractModule ds) initState
> initState = LiftState m evEnv tyEnv
> (ds', tyEnv') = evalAbstract (abstractModule ds) initState
> initState = LiftState m tyEnv
\end{verbatim}
\paragraph{Abstraction}
......@@ -55,7 +54,6 @@ i.e. the function applied to its free variables.
> data LiftState = LiftState
> { moduleIdent :: ModuleIdent
> , evalEnv :: EvalEnv
> , valueEnv :: ValueEnv
> }
......@@ -68,24 +66,17 @@ i.e. the function applied to its free variables.
> getModuleIdent :: LiftM ModuleIdent
> getModuleIdent = S.gets moduleIdent
> getEvalEnv :: LiftM EvalEnv
> getEvalEnv = S.gets evalEnv
> getValueEnv :: LiftM ValueEnv
> getValueEnv = S.gets valueEnv
> modifyValueEnv :: (ValueEnv -> ValueEnv) -> LiftM ()
> modifyValueEnv f = S.modify $ \ s -> s { valueEnv = f $ valueEnv s }
> modifyEvalEnv :: (EvalEnv -> EvalEnv) -> LiftM ()
> modifyEvalEnv f = S.modify $ \ s -> s { evalEnv = f $ evalEnv s }
> abstractModule :: [Decl] -> LiftM ([Decl], ValueEnv, EvalEnv)
> abstractModule :: [Decl] -> LiftM ([Decl], ValueEnv)
> abstractModule ds = do
> ds' <- mapM (abstractDecl "" [] Map.empty) ds
> tyEnv' <- getValueEnv
> evEnv' <- getEvalEnv
> return (ds', tyEnv', evEnv')
> return (ds', tyEnv')
> abstractDecl :: String -> [Ident] -> AbstractEnv -> Decl -> LiftM Decl
> abstractDecl _ lvs env (FunctionDecl p f eqs) =
......@@ -182,7 +173,6 @@ in the type environment.
> isLifted tyEnv f = null $ lookupValue f tyEnv
> fs' <- liftM (\tyEnv -> filter (not . isLifted tyEnv) fs) getValueEnv
> modifyValueEnv $ abstractFunTypes m pre fvs fs'
> modifyEvalEnv $ abstractFunAnnots m pre fs'
> fds' <- mapM (abstractFunDecl pre fvs lvs env')
> [d | d <- fds, any (`elem` fs') (bv d)]
> e' <- abstractFunDecls pre lvs env' fdss vds e
......@@ -199,13 +189,6 @@ in the type environment.
> (unbindFun f tyEnv')
> where ty = foldr TypeArrow (varType tyEnv' f) tys
> abstractFunAnnots :: ModuleIdent -> String -> [Ident] -> EvalEnv -> EvalEnv
> abstractFunAnnots _ pre fs evEnv = foldr abstractFunAnnot evEnv fs
> where
> abstractFunAnnot f evEnv' = case Map.lookup f evEnv' of
> Just ev -> Map.insert (liftIdent pre f) ev (Map.delete f evEnv')
> Nothing -> evEnv'
> abstractFunDecl :: String -> [Ident] -> [Ident]
> -> AbstractEnv -> Decl -> LiftM Decl
> abstractFunDecl pre fvs lvs env (FunctionDecl p f eqs) =
......
src/Transformations/Qual.lhs
View file @ bd1ca0d3
......@@ -50,7 +50,6 @@ declarations groups as well as function arguments remain unchanged.
> NewtypeDecl p n vs `liftM` qualNewConstr nc
> qualDecl (TypeDecl p n vs ty) = TypeDecl p n vs `liftM` qualTypeExpr ty
> qualDecl (TypeSig p fs ty) = TypeSig p fs `liftM` qualTypeExpr ty
> qualDecl e@(EvalAnnot _ _ _) = return e
> qualDecl (FunctionDecl p f eqs) =
> FunctionDecl p f `liftM` mapM qualEqn eqs
> qualDecl (ExternalDecl p c x n ty) =
......
src/Transformations/Simplify.lhs
View file @ bd1ca0d3
......@@ -37,13 +37,11 @@ Currently, the following optimizations are implemented:
> import Base.Types
> import Base.Typing
> import Env.Eval (EvalEnv)
> import Env.Value (ValueEnv, ValueInfo (..), bindFun, qualLookupValue)
> data SimplifyState = SimplifyState
> { moduleIdent :: ModuleIdent
> , valueEnv :: ValueEnv
> , evalEnv :: EvalEnv -- read-only!
> , nextId :: Int
> , flat :: Bool -- read-only!
> }
......@@ -66,15 +64,12 @@ Currently, the following optimizations are implemented:
> getValueEnv :: SIM ValueEnv
> getValueEnv = S.gets valueEnv
> getEvalEnv :: SIM EvalEnv
> getEvalEnv = S.gets evalEnv
> isFlat :: SIM Bool
> isFlat = S.gets flat
> simplify :: Bool -> ValueEnv -> EvalEnv -> Module -> (Module, ValueEnv)
> simplify flags tyEnv evEnv mdl@(Module m _ _ _)
> = S.evalState (simplifyModule mdl) (SimplifyState m tyEnv evEnv 1 flags)
> simplify :: Bool -> ValueEnv -> Module -> (Module, ValueEnv)
> simplify flags tyEnv mdl@(Module m _ _ _)
> = S.evalState (simplifyModule mdl) (SimplifyState m tyEnv 1 flags)
> simplifyModule :: Module -> SIM (Module, ValueEnv)
> simplifyModule (Module m es is ds) = do
......@@ -166,17 +161,15 @@ explicitly in a Curry expression.
> m <- getModuleIdent
> rhs' <- simplifyRhs env rhs
> tyEnv <- getValueEnv
> evEnv <- getEvalEnv
> return $ inlineFun m tyEnv evEnv p lhs rhs'
> return $ inlineFun m tyEnv p lhs rhs'
> inlineFun :: ModuleIdent -> ValueEnv -> EvalEnv -> Position -> Lhs -> Rhs -> [Equation]
> inlineFun m tyEnv evEnv p (FunLhs f ts)
> inlineFun :: ModuleIdent -> ValueEnv -> Position -> Lhs -> Rhs -> [Equation]
> inlineFun m tyEnv p (FunLhs f ts)
> (SimpleRhs _ (Let [FunctionDecl _ f' eqs'] e) _)
> | True -- False -- inlining of functions is deactivated (hsi)
> && f' `notElem` qfv m eqs' && e' == Variable (qualify f') &&
> n == arrowArity (funType m tyEnv (qualify f')) &&
> (evMode evEnv f == evMode evEnv f' ||
> and [all isVarPattern ts1 | Equation _ (FunLhs _ ts1) _ <- eqs']) =
> and [all isVarPattern ts1 | Equation _ (FunLhs _ ts1) _ <- eqs'] =
> map (mergeEqns p f ts' vs') eqs'
> where n :: Int -- type signature necessary for nhc
> (n,vs',ts',e') = etaReduce 0 [] (reverse ts) e
......@@ -186,7 +179,7 @@ explicitly in a Curry expression.
> etaReduce n1 vs (VariablePattern v : ts1) (Apply e1 (Variable v'))
> | qualify v == v' = etaReduce (n1+1) (v:vs) ts1 e1
> etaReduce n1 vs ts1 e1 = (n1,vs,reverse ts1,e1)
> inlineFun _ _ _ p lhs rhs = [Equation p lhs rhs]
> inlineFun _ _ p lhs rhs = [Equation p lhs rhs]
> simplifyRhs :: InlineEnv -> Rhs -> SIM Rhs
> simplifyRhs env (SimpleRhs p e _) =
......@@ -444,9 +437,6 @@ Auxiliary functions
> [Value _ _ (ForAll _ ty)] -> ty