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

Refactoring of transformations

parent 15f5f6fd
......@@ -81,10 +81,6 @@ all names must be properly qualified before calling this module.}
> import Env.Value (ValueEnv, ValueInfo (..), bindFun, bindGlobalInfo
> , lookupValue, qualLookupValue)
posE = undefined
\end{verbatim}
New identifiers may be introduced while desugaring pattern
declarations, case and $\lambda$-expressions, and list comprehensions.
......@@ -99,6 +95,18 @@ variables.
> run :: DesugarState a -> ValueEnv -> a
> run m tyEnv = S.evalState (S.evalStateT m tyEnv) 1
> getValueEnv :: DesugarState ValueEnv
> getValueEnv = S.get
> modifyValueEnv :: (ValueEnv -> ValueEnv) -> DesugarState ()
> modifyValueEnv = S.modify
> getNextId :: DesugarState Int
> getNextId = S.lift $ do
> nid <- S.get
> S.modify succ
> return nid
\end{verbatim}
The desugaring phase keeps only the type, function, and value
declarations of the module. In the current version record declarations
......@@ -125,7 +133,7 @@ as it allows value declarations at the top-level of a module.
> dss <- mapM (desugarRecordDecl m tcEnv) ds
> let ds' = concat dss
> ds'' <- desugarDeclGroup m tcEnv ds'
> tyEnv' <- S.get
> tyEnv' <- getValueEnv
> return (filter isTypeDecl ds' ++ ds'', tyEnv')
\end{verbatim}
......@@ -149,7 +157,7 @@ declarations to the group that must be desugared as well.
> return (PatternDecl p t' rhs : concat dss')
> desugarDeclLhs m _ (FlatExternalDecl p fs) =
> do
> tyEnv <- S.get
> tyEnv <- getValueEnv
> return (map (externalDecl tyEnv p) fs)
> where externalDecl tyEnv p' f =
> ExternalDecl p' CallConvPrimitive (Just (name f)) f
......@@ -173,7 +181,7 @@ and a record label belongs to only one record declaration.
> desugarDeclRhs :: ModuleIdent -> TCEnv -> Decl -> DesugarState Decl
> desugarDeclRhs m tcEnv (FunctionDecl p f eqs) =
> do
> tyEnv <- S.get
> tyEnv <- getValueEnv
> let ty = (flip typeOf (Variable (qual f))) tyEnv
> liftM (FunctionDecl p f)
> (mapM (desugarEquation m tcEnv (arrowArgs ty)) eqs)
......@@ -208,7 +216,7 @@ with a local declaration for $v$.
> desugarLiteral :: Literal -> DesugarState (Either Literal ([SrcRef],[Literal]))
> desugarLiteral (Char p c) = return (Left (Char p c))
> desugarLiteral (Int v i) = liftM (Left . fixType) S.get
> desugarLiteral (Int v i) = liftM (Left . fixType) getValueEnv
> where
> fixType tyEnv
> | typeOf tyEnv v == floatType
......@@ -243,7 +251,7 @@ with a local declaration for $v$.
> desugarTerm _ _ _ ds (VariablePattern v) = return (ds,VariablePattern v)
> desugarTerm m tcEnv p ds (ConstructorPattern c [t]) =
> do
> tyEnv <- S.get
> tyEnv <- getValueEnv
> liftM (if isNewtypeConstr tyEnv c then id else second (constrPat c))
> (desugarTerm m tcEnv p ds t)
> where constrPat c' t' = ConstructorPattern c' [t']
......@@ -271,7 +279,7 @@ with a local declaration for $v$.
> desugarTerm m tcEnv p ds (RecordPattern fs _)
> | null fs = internalError "Desugar.desugarTerm: empty record"
> | otherwise =
> do tyEnv <- S.get
> do tyEnv <- getValueEnv
> case (lookupValue (fieldLabel (head fs)) tyEnv) of
> [Label _ r _] ->
> desugarRecordPattern m tcEnv p ds (map field2Tuple fs) r
......@@ -292,7 +300,7 @@ with a local declaration for $v$.
> AsPattern v t' -> liftM (desugarAs p v) (desugarLazy pos m p ds t')
> LazyPattern pos' t' -> desugarLazy pos' m p ds t'
> _ -> do
> v0 <- S.get >>= freshIdent m "_#lazy" . monoType . flip typeOf t
> v0 <- getValueEnv >>= freshIdent m "_#lazy" . monoType . flip typeOf t
> let v' = addPositionIdent (AST pos) v0
> return (patDecl p{astRef=pos} t (mkVar v') : ds, VariablePattern v')
......@@ -309,7 +317,7 @@ type \texttt{Bool} of the guard because the guard's type defaults to
> desugarRhs :: ModuleIdent -> TCEnv -> Position -> Rhs -> DesugarState Rhs
> desugarRhs m tcEnv p rhs =
> do
> tyEnv <- S.get
> tyEnv <- getValueEnv
> e' <- desugarExpr m tcEnv p (expandRhs tyEnv prelFailed rhs)
> return (SimpleRhs p e' [])
......@@ -362,7 +370,7 @@ type \texttt{Bool} of the guard because the guard's type defaults to
> liftM (apply prelEnumFromThenTo) (mapM (desugarExpr m tcEnv p) [e1,e2,e3])
> desugarExpr m tcEnv p (UnaryMinus op e) =
> do
> tyEnv <- S.get
> tyEnv <- getValueEnv
> liftM (Apply (unaryMinus op (typeOf tyEnv e))) (desugarExpr m tcEnv p e)
> where unaryMinus op1 ty
> | op1 == minusId =
......@@ -371,7 +379,7 @@ type \texttt{Bool} of the guard because the guard's type defaults to
> | otherwise = internalError "Desugar.unaryMinus"
> desugarExpr m tcEnv p (Apply (Constructor c) e) =
> do
> tyEnv <- S.get
> tyEnv <- getValueEnv
> liftM (if isNewtypeConstr tyEnv c then id else (Apply (Constructor c)))
> (desugarExpr m tcEnv p e)
> desugarExpr m tcEnv p (Apply e1 e2) =
......@@ -396,9 +404,8 @@ type \texttt{Bool} of the guard because the guard's type defaults to
> e' <- desugarExpr m tcEnv p e
> return (Apply (Apply prelFlip op') e')
> desugarExpr m tcEnv p expr@(Lambda r ts e) = do
> f <- S.get >>=
> freshIdent m "_#lambda" . polyType . flip typeOf expr
> desugarExpr m tcEnv p (Let [funDecl (AST r) f ts e] (mkVar f))
> f <- getValueEnv >>= freshIdent m "_#lambda" . polyType . flip typeOf expr
> desugarExpr m tcEnv p $ Let [funDecl (AST r) f ts e] $ mkVar f
> desugarExpr m tcEnv p (Let ds e) = do
> ds' <- desugarDeclGroup m tcEnv ds
> e' <- desugarExpr m tcEnv p e
......@@ -419,9 +426,9 @@ type \texttt{Bool} of the guard because the guard's type defaults to
> | otherwise =
> do
> e' <- desugarExpr m tcEnv p e
> v <- S.get >>= freshIdent m "_#case" . monoType . flip typeOf e
> v <- getValueEnv >>= freshIdent m "_#case" . monoType . flip typeOf e
> alts' <- mapM (desugarAltLhs m tcEnv) alts
> tyEnv <- S.get
> tyEnv <- getValueEnv
> alts'' <- mapM (desugarAltRhs m tcEnv)
> (map (expandAlt tyEnv v) (init (tails alts')))
> return (mkCase m v e' alts'')
......@@ -433,12 +440,12 @@ type \texttt{Bool} of the guard because the guard's type defaults to
> | otherwise =
> do let l = fieldLabel (head fs)
> fs' = map field2Tuple fs
> tyEnv <- S.get
> tyEnv <- getValueEnv
> case (lookupValue l tyEnv) of
> [Label _ r _] -> desugarRecordConstr m tcEnv p r fs'
> _ -> internalError "Desugar.desugarExpr: illegal record construction"
> desugarExpr m tcEnv p (RecordSelection e l) =
> do tyEnv <- S.get
> do tyEnv <- getValueEnv
> case (lookupValue l tyEnv) of
> [Label _ r _] -> desugarRecordSelection m tcEnv p r l e
> _ -> internalError "Desugar.desugarExpr: illegal record selection"
......@@ -447,7 +454,7 @@ type \texttt{Bool} of the guard because the guard's type defaults to
> | otherwise =
> do let l = fieldLabel (head fs)
> fs' = map field2Tuple fs
> tyEnv <- S.get
> tyEnv <- getValueEnv
> case (lookupValue l tyEnv) of
> [Label _ r _] -> desugarRecordUpdate m tcEnv p r rexpr fs'
> _ -> internalError "Desugar.desugarExpr: illegal record update"
......@@ -511,14 +518,14 @@ have to be desugared as well. This part transforms the following extensions:
> desugarRecordDecl m tcEnv (TypeDecl p r vs (RecordType fss _)) =
> case (qualLookupTC r' tcEnv) of
> [AliasType _ n (TypeRecord fs' _)] ->
> do _ <- S.get
> do _ <- getValueEnv
> let tys = concatMap (\ (ls,ty) -> replicate (length ls) ty) fss
> --tys' = map (elimRecordTypes tyEnv) tys
> rdecl = DataDecl p r vs [ConstrDecl p [] r tys]
> rty' = TypeConstructor r' (map TypeVariable [0 .. n-1])
> rcts' = ForAllExist 0 n (foldr TypeArrow rty' (map snd fs'))
> rfuncs <- mapM (genRecordFuncs m tcEnv p r' rty' (map fst fs')) fs'
> S.modify (bindGlobalInfo (flip DataConstructor (length tys)) m r rcts')
> modifyValueEnv (bindGlobalInfo (flip DataConstructor (length tys)) m r rcts')
> return (rdecl:(concat rfuncs))
> _ -> internalError "Desugar.desugarRecordDecl: no record"
> where r' = qualifyWith m r
......@@ -567,7 +574,7 @@ have to be desugared as well. This part transforms the following extensions:
> elimFunctionPattern _ _ [] = return ([],[])
> elimFunctionPattern m p (t:ts)
> | containsFunctionPattern t
> = do tyEnv <- S.get
> = do tyEnv <- getValueEnv
> ident <- freshIdent m "_#funpatt" (monoType (typeOf tyEnv t))
> (ts',its') <- elimFunctionPattern m p ts
> return ((VariablePattern ident):ts', (ident,t):its')
......@@ -664,7 +671,7 @@ have to be desugared as well. This part transforms the following extensions:
> (updId, updFunc) = genUpdateFunc m p r ls l
> selType = polyType (TypeArrow rty ty)
> updType = polyType (TypeArrow rty (TypeArrow ty rty))
> S.modify (bindFun m selId 1 selType . bindFun m updId 2 updType)
> modifyValueEnv (bindFun m selId 1 selType . bindFun m updId 2 updType)
> return [selFunc, updFunc]
> _ -> internalError "Desugar.genRecordFuncs: wrong type"
......@@ -734,7 +741,7 @@ instead of \texttt{(++)} and \texttt{map} in place of
> desugarQual m tcEnv p (StmtBind refBind t l) e
> | isVarPattern t = desugarExpr m tcEnv p (qualExpr t e l)
> | otherwise = do
> tyEnv <- S.get
> tyEnv <- getValueEnv
> v0 <- freshIdent m "_#var" (monoType (typeOf tyEnv t))
> l0 <- freshIdent m "_#var" (monoType (typeOf tyEnv e))
> let v = addRefId refBind v0
......@@ -762,12 +769,11 @@ Generation of fresh names
\begin{verbatim}
> freshIdent :: ModuleIdent -> String -> TypeScheme -> DesugarState Ident
> freshIdent m prefix ty =
> do
> x <- liftM (mkName prefix) (S.lift (S.modify succ >> S.get))
> S.modify (bindFun m x (arrowArity $ unscheme ty) ty)
> return x
> where mkName pre n = mkIdent (pre ++ show n)
> freshIdent m prefix ty = do
> x <- mkName prefix `liftM` getNextId
> modifyValueEnv $ bindFun m x (arrowArity $ unscheme ty) ty
> return x
> where mkName pre n = mkIdent $ pre ++ show n
> unscheme (ForAll _ t) = t
\end{verbatim}
......
......@@ -37,12 +37,10 @@ lifted to the top-level.
> import Env.Value
> lift :: ValueEnv -> EvalEnv -> Module -> (Module, ValueEnv, EvalEnv)
> lift tyEnv evEnv (Module m es is ds) =
> (lifted, tyEnv', evEnv')
> lift tyEnv evEnv (Module m es is ds) = (lifted, tyEnv', evEnv')
> where
> lifted = Module m es is $ concatMap liftFunDecl ds'
> (ds',tyEnv',evEnv')
> = S.evalState (S.evalStateT (abstractModule m ds) tyEnv) evEnv
> lifted = Module m es is $ concatMap liftFunDecl ds'
> (ds', tyEnv', evEnv') = evalAbstract (abstractModule m ds) tyEnv evEnv
\end{verbatim}
\paragraph{Abstraction}
......@@ -58,14 +56,28 @@ i.e. the function applied to its free variables.
> type AbstractState a = S.StateT ValueEnv (S.State EvalEnv) a
> type AbstractEnv = Map.Map Ident Expression
> evalAbstract :: AbstractState a -> ValueEnv -> EvalEnv -> a
> evalAbstract st tyEnv evEnv = S.evalState (S.evalStateT st tyEnv) evEnv
> getValueEnv :: AbstractState ValueEnv
> getValueEnv = S.get
> modifyValueEnv :: (ValueEnv -> ValueEnv) -> AbstractState ()
> modifyValueEnv = S.modify
> getEvalEnv :: AbstractState EvalEnv
> getEvalEnv = S.lift S.get
> modifyEvalEnv :: (EvalEnv -> EvalEnv) -> AbstractState ()
> modifyEvalEnv = S.lift . S.modify
> abstractModule :: ModuleIdent -> [Decl]
> -> AbstractState ([Decl], ValueEnv, EvalEnv)
> abstractModule m ds =
> do
> ds' <- mapM (abstractDecl m "" [] Map.empty) ds
> tyEnv' <- S.get
> evEnv' <- S.lift S.get
> return (ds',tyEnv',evEnv')
> abstractModule m ds = do
> ds' <- mapM (abstractDecl m "" [] Map.empty) ds
> tyEnv' <- getValueEnv
> evEnv' <- getEvalEnv
> return (ds',tyEnv',evEnv')
> abstractDecl :: ModuleIdent -> String -> [Ident] -> AbstractEnv -> Decl
> -> AbstractState Decl
......@@ -151,24 +163,25 @@ in the type environment.
> -> [[Decl]] -> [Decl] -> Expression
> -> AbstractState Expression
> abstractFunDecls m pre lvs env [] vds e = do
> vds' <- mapM (abstractDecl m pre lvs env) vds
> e' <- abstractExpr m pre lvs env e
> return (Let vds' e')
> vds' <- mapM (abstractDecl m pre lvs env) vds
> e' <- abstractExpr m pre lvs env e
> return (Let vds' e')
> abstractFunDecls m pre lvs env (fds:fdss) vds e = do
> fs' <- liftM (\tyEnv -> filter (not . isLifted tyEnv) fs) S.get
> S.modify (abstractFunTypes m pre fvs fs')
> S.lift (S.modify (abstractFunAnnots m pre fs'))
> fds' <- mapM (abstractFunDecl m pre fvs lvs env')
> [d | d <- fds, any (`elem` fs') (bv d)]
> e' <- abstractFunDecls m pre lvs env' fdss vds e
> return (Let fds' e')
> where fs = bv fds
> fvs = filter (`elem` lvs) (Set.toList fvsRhs)
> env' = foldr (bindF (map mkVar fvs)) env fs
> fvsRhs = Set.unions
> [Set.fromList (maybe [v] (qfv m) (Map.lookup v env)) | v <- qfv m fds]
> bindF fvs' f = Map.insert f (apply (mkFun m pre f) fvs')
> 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 m pre fvs lvs env')
> [d | d <- fds, any (`elem` fs') (bv d)]
> e' <- abstractFunDecls m pre lvs env' fdss vds e
> return (Let fds' e')
> where
> fs = bv fds
> fvs = filter (`elem` lvs) (Set.toList fvsRhs)
> env' = foldr (bindF (map mkVar fvs)) env fs
> fvsRhs = Set.unions
> [Set.fromList (maybe [v] (qfv m) (Map.lookup v env)) | v <- qfv m fds]
> bindF fvs' f = Map.insert f (apply (mkFun m pre f) fvs')
> isLifted tyEnv f = null (lookupValue f tyEnv)
> abstractFunTypes :: ModuleIdent -> String -> [Ident] -> [Ident]
> -> ValueEnv -> ValueEnv
......@@ -176,7 +189,6 @@ in the type environment.
> where tys = map (varType tyEnv) fvs
> abstractFunType f tyEnv' =
> qualBindFun m (liftIdent pre f)
> (length tys)
> (foldr TypeArrow (varType tyEnv' f) tys)
> (unbindFun f tyEnv')
......@@ -201,23 +213,21 @@ in the type environment.
> abstractExpr :: ModuleIdent -> String -> [Ident] -> AbstractEnv
> -> Expression -> AbstractState Expression
> abstractExpr _ _ _ _ (Literal l) = return (Literal l)
> abstractExpr m pre lvs env (Variable v)
> | isQualified v = return (Variable v)
> | otherwise = maybe (return (Variable v)) (abstractExpr m pre lvs env)
> (Map.lookup (unqualify v) env)
> abstractExpr _ _ _ _ (Constructor c) = return (Constructor c)
> abstractExpr m pre lvs env (Apply e1 e2) =
> do
> e1' <- abstractExpr m pre lvs env e1
> e2' <- abstractExpr m pre lvs env e2
> return (Apply e1' e2')
> abstractExpr _ _ _ _ l@(Literal _) = return l
> abstractExpr m pre lvs env var@(Variable v)
> | isQualified v = return var
> | otherwise = maybe (return var) (abstractExpr m pre lvs env)
> (Map.lookup (unqualify v) env)
> abstractExpr _ _ _ _ c@(Constructor _) = return c
> abstractExpr m pre lvs env (Apply e1 e2) = do
> e1' <- abstractExpr m pre lvs env e1
> e2' <- abstractExpr m pre lvs env e2
> return (Apply e1' e2')
> abstractExpr m pre lvs env (Let ds e) = abstractDeclGroup m pre lvs env ds e
> abstractExpr m pre lvs env (Case r e alts) =
> do
> e' <- abstractExpr m pre lvs env e
> alts' <- mapM (abstractAlt m pre lvs env) alts
> return (Case r e' alts')
> abstractExpr m pre lvs env (Case r e alts) = do
> e' <- abstractExpr m pre lvs env e
> alts' <- mapM (abstractAlt m pre lvs env) alts
> return (Case r e' alts')
> abstractExpr _ _ _ _ _ = internalError "Lift.abstractExpr"
> abstractAlt :: ModuleIdent -> String -> [Ident] -> AbstractEnv -> Alt
......@@ -256,35 +266,34 @@ to the top-level.
> where (fds,vds) = partition isFunDecl ds
> (vds',dss') = unzip (map liftVarDecl vds)
> liftExpr :: Expression -> (Expression,[Decl])
> liftExpr (Literal l) = (Literal l,[])
> liftExpr (Variable v) = (Variable v,[])
> liftExpr (Constructor c) = (Constructor c,[])
> liftExpr (Apply e1 e2) = (Apply e1' e2',ds' ++ ds'')
> where (e1',ds') = liftExpr e1
> (e2',ds'') = liftExpr e2
> liftExpr (Let ds e) = (mkLet ds' e',ds'' ++ ds''')
> where (ds',ds'') = liftDeclGroup ds
> (e',ds''') = liftExpr e
> liftExpr :: Expression -> (Expression, [Decl])
> liftExpr l@(Literal _) = (l, [])
> liftExpr v@(Variable _) = (v, [])
> liftExpr c@(Constructor _) = (c, [])
> liftExpr (Apply e1 e2) = (Apply e1' e2', ds' ++ ds'')
> where (e1', ds' ) = liftExpr e1
> (e2', ds'') = liftExpr e2
> liftExpr (Let ds e) = (mkLet ds' e', ds'' ++ ds''')
> where (ds', ds'' ) = liftDeclGroup ds
> (e' , ds''') = liftExpr e
> mkLet ds1 e1 = if null ds1 then e1 else Let ds1 e1
> liftExpr (Case r e alts) = (Case r e' alts',concat (ds':dss'))
> where (e',ds') = liftExpr e
> (alts',dss') = unzip (map liftAlt alts)
> liftExpr (Case r e alts) = (Case r e' alts', concat $ ds':dss')
> where (e' ,ds' ) = liftExpr e
> (alts',dss') = unzip $ map liftAlt alts
> liftExpr _ = internalError "Lift.liftExpr"
> liftAlt :: Alt -> (Alt,[Decl])
> liftAlt (Alt p t rhs) = (Alt p t rhs',ds')
> where (rhs',ds') = liftRhs rhs
> liftAlt (Alt p t rhs) = (Alt p t rhs', ds')
> where (rhs', ds') = liftRhs rhs
\end{verbatim}
\paragraph{Auxiliary definitions}
\begin{verbatim}
> isFunDecl :: Decl -> Bool
> isFunDecl (FunctionDecl _ _ _) = True
> isFunDecl (FunctionDecl _ _ _) = True
> isFunDecl (ExternalDecl _ _ _ _ _) = True
> isFunDecl _ = False
> isFunDecl _ = False
> mkFun :: ModuleIdent -> String -> Ident -> Expression
> mkFun m pre f = Variable (qualifyWith m (liftIdent pre f))
......@@ -295,9 +304,9 @@ to the top-level.
> apply :: Expression -> [Expression] -> Expression
> apply = foldl Apply
> qualBindFun :: ModuleIdent -> Ident -> Int -> Type -> ValueEnv -> ValueEnv
> qualBindFun m f a ty = qualBindTopEnv "Lift.qualBindFun" qf $
> Value qf a (polyType ty)
> qualBindFun :: ModuleIdent -> Ident -> Type -> ValueEnv -> ValueEnv
> qualBindFun m f ty = qualBindTopEnv "Lift.qualBindFun" qf $
> Value qf (arrowArity ty) (polyType ty)
> where qf = qualifyWith m f
> unbindFun :: Ident -> ValueEnv -> ValueEnv
......@@ -305,12 +314,11 @@ to the top-level.
> varType :: ValueEnv -> Ident -> Type
> varType tyEnv v = case lookupValue v tyEnv of
> [Value _ _ (ForAll _ ty)] -> ty
> _ -> internalError $ "Lift.varType " ++ show v
> [Value _ _ (ForAll _ ty)] -> ty
> _ -> internalError $ "Lift.varType " ++ show v
> liftIdent :: String -> Ident -> Ident
> liftIdent prefix x =
> renameIdent (mkIdent (prefix ++ (show x))) (uniqueId x)
> --renameIdent (mkIdent (prefix ++ name x ++ show (uniqueId x))) (uniqueId x)
> liftIdent prefix x = renameIdent (mkIdent $ prefix ++ show x) $ uniqueId x
> --renameIdent (mkIdent (prefix ++ name x ++ show (uniqueId x))) (uniqueId x)
\end{verbatim}
......@@ -45,6 +45,12 @@ Currently, the following optimizations are implemented:
> type InlineEnv = Map.Map Ident Expression
> type SimplifyFlags = Bool
> getNextId :: SimplifyState Int
> getNextId = S.lift $ R.lift $ do
> nid <- S.get
> S.modify succ
> return nid
> flatFlag :: SimplifyFlags -> Bool
> flatFlag x = x
......@@ -453,7 +459,7 @@ Auxiliary functions
> freshIdent :: ModuleIdent -> (Int -> Ident) -> TypeScheme
> -> SimplifyState Ident
> freshIdent m f ty@(ForAll _ t) = do
> x <- liftM f (S.lift (R.lift ( S.modify succ >> S.get)))
> x <- f `liftM` getNextId
> S.modify (bindFun m x arity ty)
> return x
> where arity = arrowArity t
......
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